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

   1 ;;; gnus-art.el --- article mode commands for Gnus
   2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'custom)
  31 (require 'gnus)
  32 (require 'gnus-sum)
  33 (require 'gnus-spec)
  34 (require 'gnus-int)
  35 (require 'browse-url)
  36 (require 'mm-bodies)
  37 (require 'mail-parse)
  38 (require 'mm-decode)
  39 (require 'mm-view)
  40 (require 'wid-edit)
  41 (require 'mm-uu)
  42
  43 (defgroup gnus-article nil
  44   "Article display."
  45   :link '(custom-manual "(gnus)The Article Buffer")
  46   :group 'gnus)
  47
  48 (defgroup gnus-article-hiding nil
  49   "Hiding article parts."
  50   :link '(custom-manual "(gnus)Article Hiding")
  51   :group 'gnus-article)
  52
  53 (defgroup gnus-article-highlight nil
  54   "Article highlighting."
  55   :link '(custom-manual "(gnus)Article Highlighting")
  56   :group 'gnus-article
  57   :group 'gnus-visual)
  58
  59 (defgroup gnus-article-signature nil
  60   "Article signatures."
  61   :link '(custom-manual "(gnus)Article Signature")
  62   :group 'gnus-article)
  63
  64 (defgroup gnus-article-headers nil
  65   "Article headers."
  66   :link '(custom-manual "(gnus)Hiding Headers")
  67   :group 'gnus-article)
  68
  69 (defgroup gnus-article-washing nil
  70   "Special commands on articles."
  71   :link '(custom-manual "(gnus)Article Washing")
  72   :group 'gnus-article)
  73
  74 (defgroup gnus-article-emphasis nil
  75   "Fontisizing articles."
  76   :link '(custom-manual "(gnus)Article Fontisizing")
  77   :group 'gnus-article)
  78
  79 (defgroup gnus-article-saving nil
  80   "Saving articles."
  81   :link '(custom-manual "(gnus)Saving Articles")
  82   :group 'gnus-article)
  83
  84 (defgroup gnus-article-mime nil
  85   "Worshiping the MIME wonder."
  86   :link '(custom-manual "(gnus)Using MIME")
  87   :group 'gnus-article)
  88
  89 (defgroup gnus-article-buttons nil
  90   "Pushable buttons in the article buffer."
  91   :link '(custom-manual "(gnus)Article Buttons")
  92   :group 'gnus-article)
  93
  94 (defgroup gnus-article-various nil
  95   "Other article options."
  96   :link '(custom-manual "(gnus)Misc Article")
  97   :group 'gnus-article)
  98
  99 (defcustom gnus-ignored-headers
 100   '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
 101     "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
 102     "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
 103     "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
 104     "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
 105     "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
 106     "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
 107     "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
 108     "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
 109     "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
 110     "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
 111     "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
 112     "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
 113     "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
 114     "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
 115     "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
 116     "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
 117     "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
 118     "^Status:")
 119   "*All headers that start with this regexp will be hidden.
 120 This variable can also be a list of regexps of headers to be ignored.
 121 If `gnus-visible-headers' is non-nil, this variable will be ignored."
 122   :type '(choice :custom-show nil
 123                  regexp
 124                  (repeat regexp))
 125   :group 'gnus-article-hiding)
 126
 127 (defcustom gnus-visible-headers
 128   "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:"
 129   "*All headers that do not match this regexp will be hidden.
 130 This variable can also be a list of regexp of headers to remain visible.
 131 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
 132   :type '(repeat :value-to-internal (lambda (widget value)
 133                                       (custom-split-regexp-maybe value))
 134                  :match (lambda (widget value)
 135                           (or (stringp value)
 136                               (widget-editable-list-match widget value)))
 137                  regexp)
 138   :group 'gnus-article-hiding)
 139
 140 (defcustom gnus-sorted-header-list
 141   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
 142     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
 143   "*This variable is a list of regular expressions.
 144 If it is non-nil, headers that match the regular expressions will
 145 be placed first in the article buffer in the sequence specified by
 146 this list."
 147   :type '(repeat regexp)
 148   :group 'gnus-article-hiding)
 149
 150 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
 151   "Headers that are only to be displayed if they have interesting data.
 152 Possible values in this list are `empty', `newsgroups', `followup-to',
 153 `reply-to', `date', `long-to', and `many-to'."
 154   :type '(set (const :tag "Headers with no content." empty)
 155               (const :tag "Newsgroups with only one group." newsgroups)
 156               (const :tag "Followup-to identical to newsgroups." followup-to)
 157               (const :tag "Reply-to identical to from." reply-to)
 158               (const :tag "Date less than four days old." date)
 159               (const :tag "Very long To header." long-to)
 160               (const :tag "Multiple To headers." many-to))
 161   :group 'gnus-article-hiding)
 162
 163 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
 164   "Regexp matching signature separator.
 165 This can also be a list of regexps.  In that case, it will be checked
 166 from head to tail looking for a separator.  Searches will be done from
 167 the end of the buffer."
 168   :type '(repeat string)
 169   :group 'gnus-article-signature)
 170
 171 (defcustom gnus-signature-limit nil
 172    "Provide a limit to what is considered a signature.
 173 If it is a number, no signature may not be longer (in characters) than
 174 that number.  If it is a floating point number, no signature may be
 175 longer (in lines) than that number.  If it is a function, the function
 176 will be called without any parameters, and if it returns nil, there is
 177 no signature in the buffer.  If it is a string, it will be used as a
 178 regexp.  If it matches, the text in question is not a signature."
 179   :type '(choice (integer :value 200)
 180                  (number :value 4.0)
 181                  (function :value fun)
 182                  (regexp :value ".*"))
 183   :group 'gnus-article-signature)
 184
 185 (defcustom gnus-hidden-properties '(invisible t intangible t)
 186   "Property list to use for hiding text."
 187   :type 'sexp
 188   :group 'gnus-article-hiding)
 189
 190 (defcustom gnus-article-x-face-command
 191   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
 192   "*String or function to be executed to display an X-Face header.
 193 If it is a string, the command will be executed in a sub-shell
 194 asynchronously.  The compressed face will be piped to this command."
 195   :type 'string                         ;Leave function case to Lisp.
 196   :group 'gnus-article-washing)
 197
 198 (defcustom gnus-article-x-face-too-ugly nil
 199   "Regexp matching posters whose face shouldn't be shown automatically."
 200   :type '(choice regexp (const nil))
 201   :group 'gnus-article-washing)
 202
 203 (defcustom gnus-emphasis-alist
 204   (let ((format
 205          "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")
 206         (types
 207          '(("_" "_" underline)
 208            ("/" "/" italic)
 209            ("\\*" "\\*" bold)
 210            ("_/" "/_" underline-italic)
 211            ("_\\*" "\\*_" underline-bold)
 212            ("\\*/" "/\\*" bold-italic)
 213            ("_\\*/" "/\\*_" underline-bold-italic))))
 214     `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
 215        2 3 gnus-emphasis-underline)
 216       ,@(mapcar
 217          (lambda (spec)
 218            (list
 219             (format format (car spec) (cadr spec))
 220             2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
 221          types)))
 222   "*Alist that says how to fontify certain phrases.
 223 Each item looks like this:
 224
 225   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
 226
 227 The first element is a regular expression to be matched.  The second
 228 is a number that says what regular expression grouping used to find
 229 the entire emphasized word.  The third is a number that says what
 230 regexp grouping should be displayed and highlighted.  The fourth
 231 is the face used for highlighting."
 232   :type '(repeat (list :value ("" 0 0 default)
 233                        regexp
 234                        (integer :tag "Match group")
 235                        (integer :tag "Emphasize group")
 236                        face))
 237   :group 'gnus-article-emphasis)
 238
 239 (defface gnus-emphasis-bold '((t (:bold t)))
 240   "Face used for displaying strong emphasized text (*word*)."
 241   :group 'gnus-article-emphasis)
 242
 243 (defface gnus-emphasis-italic '((t (:italic t)))
 244   "Face used for displaying italic emphasized text (/word/)."
 245   :group 'gnus-article-emphasis)
 246
 247 (defface gnus-emphasis-underline '((t (:underline t)))
 248   "Face used for displaying underlined emphasized text (_word_)."
 249   :group 'gnus-article-emphasis)
 250
 251 (defface gnus-emphasis-underline-bold '((t (:bold t :underline t)))
 252   "Face used for displaying underlined bold emphasized text (_*word*_)."
 253   :group 'gnus-article-emphasis)
 254
 255 (defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
 256   "Face used for displaying underlined italic emphasized text (_*word*_)."
 257   :group 'gnus-article-emphasis)
 258
 259 (defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
 260   "Face used for displaying bold italic emphasized text (/*word*/)."
 261   :group 'gnus-article-emphasis)
 262
 263 (defface gnus-emphasis-underline-bold-italic
 264   '((t (:bold t :italic t :underline t)))
 265   "Face used for displaying underlined bold italic emphasized text.
 266 Esample: (_/*word*/_)."
 267   :group 'gnus-article-emphasis)
 268
 269 (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
 270   "Format for display of Date headers in article bodies.
 271 See `format-time-string' for the possible values.
 272
 273 The variable can also be function, which should return a complete Date
 274 header.  The function is called with one argument, the time, which can
 275 be fed to `format-time-string'."
 276   :type '(choice string symbol)
 277   :link '(custom-manual "(gnus)Article Date")
 278   :group 'gnus-article-washing)
 279
 280 (eval-and-compile
 281   (autoload 'mail-extract-address-components "mail-extr"))
 282
 283 (defcustom gnus-save-all-headers t
 284   "*If non-nil, don't remove any headers before saving."
 285   :group 'gnus-article-saving
 286   :type 'boolean)
 287
 288 (defcustom gnus-prompt-before-saving 'always
 289   "*This variable says how much prompting is to be done when saving articles.
 290 If it is nil, no prompting will be done, and the articles will be
 291 saved to the default files.  If this variable is `always', each and
 292 every article that is saved will be preceded by a prompt, even when
 293 saving large batches of articles.  If this variable is neither nil not
 294 `always', there the user will be prompted once for a file name for
 295 each invocation of the saving commands."
 296   :group 'gnus-article-saving
 297   :type '(choice (item always)
 298                  (item :tag "never" nil)
 299                  (sexp :tag "once" :format "%t\n" :value t)))
 300
 301 (defcustom gnus-saved-headers gnus-visible-headers
 302   "Headers to keep if `gnus-save-all-headers' is nil.
 303 If `gnus-save-all-headers' is non-nil, this variable will be ignored.
 304 If that variable is nil, however, all headers that match this regexp
 305 will be kept while the rest will be deleted before saving."
 306   :group 'gnus-article-saving
 307   :type 'regexp)
 308
 309 (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
 310   "A function to save articles in your favourite format.
 311 The function must be interactively callable (in other words, it must
 312 be an Emacs command).
 313
 314 Gnus provides the following functions:
 315
 316 * gnus-summary-save-in-rmail (Rmail format)
 317 * gnus-summary-save-in-mail (Unix mail format)
 318 * gnus-summary-save-in-folder (MH folder)
 319 * gnus-summary-save-in-file (article format)
 320 * gnus-summary-save-in-vm (use VM's folder format)
 321 * gnus-summary-write-to-file (article format -- overwrite)."
 322   :group 'gnus-article-saving
 323   :type '(radio (function-item gnus-summary-save-in-rmail)
 324                 (function-item gnus-summary-save-in-mail)
 325                 (function-item gnus-summary-save-in-folder)
 326                 (function-item gnus-summary-save-in-file)
 327                 (function-item gnus-summary-save-in-vm)
 328                 (function-item gnus-summary-write-to-file)))
 329
 330 (defcustom gnus-rmail-save-name 'gnus-plain-save-name
 331   "A function generating a file name to save articles in Rmail format.
 332 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 333   :group 'gnus-article-saving
 334   :type 'function)
 335
 336 (defcustom gnus-mail-save-name 'gnus-plain-save-name
 337   "A function generating a file name to save articles in Unix mail format.
 338 The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
 339   :group 'gnus-article-saving
 340   :type 'function)
 341
 342 (defcustom gnus-folder-save-name 'gnus-folder-save-name
 343   "A function generating a file name to save articles in MH folder.
 344 The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER."
 345   :group 'gnus-article-saving
 346   :type 'function)
 347
 348 (defcustom gnus-file-save-name 'gnus-numeric-save-name
 349   "A function generating a file name to save articles in article format.
 350 The function is called with NEWSGROUP, HEADERS, and optional
 351 LAST-FILE."
 352   :group 'gnus-article-saving
 353   :type 'function)
 354
 355 (defcustom gnus-split-methods
 356   '((gnus-article-archive-name)
 357     (gnus-article-nndoc-name))
 358   "*Variable used to suggest where articles are to be saved.
 359 For instance, if you would like to save articles related to Gnus in
 360 the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
 361 you could set this variable to something like:
 362
 363  '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
 364    (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
 365
 366 This variable is an alist where the where the key is the match and the
 367 value is a list of possible files to save in if the match is non-nil.
 368
 369 If the match is a string, it is used as a regexp match on the
 370 article.  If the match is a symbol, that symbol will be funcalled
 371 from the buffer of the article to be saved with the newsgroup as the
 372 parameter.  If it is a list, it will be evaled in the same buffer.
 373
 374 If this form or function returns a string, this string will be used as
 375 a possible file name; and if it returns a non-nil list, that list will
 376 be used as possible file names."
 377   :group 'gnus-article-saving
 378   :type '(repeat (choice (list :value (fun) function)
 379                          (cons :value ("" "") regexp (repeat string))
 380                          (sexp :value nil))))
 381
 382 (defcustom gnus-page-delimiter "^\^L"
 383   "*Regexp describing what to use as article page delimiters.
 384 The default value is \"^\^L\", which is a form linefeed at the
 385 beginning of a line."
 386   :type 'regexp
 387   :group 'gnus-article-various)
 388
 389 (defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
 390   "*The format specification for the article mode line.
 391 See `gnus-summary-mode-line-format' for a closer description.
 392
 393 The following additional specs are available:
 394
 395 %w  The article washing status.
 396 %m  The number of MIME parts in the article."
 397   :type 'string
 398   :group 'gnus-article-various)
 399
 400 (defcustom gnus-article-mode-hook nil
 401   "*A hook for Gnus article mode."
 402   :type 'hook
 403   :group 'gnus-article-various)
 404
 405 (defcustom gnus-article-menu-hook nil
 406   "*Hook run after the creation of the article mode menu."
 407   :type 'hook
 408   :group 'gnus-article-various)
 409
 410 (defcustom gnus-article-prepare-hook nil
 411   "*A hook called after an article has been prepared in the article buffer.
 412 If you want to run a special decoding program like nkf, use this hook."
 413   :type 'hook
 414   :group 'gnus-article-various)
 415
 416 (defcustom gnus-article-hide-pgp-hook nil
 417   "*A hook called after successfully hiding a PGP signature."
 418   :type 'hook
 419   :group 'gnus-article-various)
 420
 421 (defcustom gnus-article-button-face 'bold
 422   "Face used for highlighting buttons in the article buffer.
 423
 424 An article button is a piece of text that you can activate by pressing
 425 `RET' or `mouse-2' above it."
 426   :type 'face
 427   :group 'gnus-article-buttons)
 428
 429 (defcustom gnus-article-mouse-face 'highlight
 430   "Face used for mouse highlighting in the article buffer.
 431
 432 Article buttons will be displayed in this face when the cursor is
 433 above them."
 434   :type 'face
 435   :group 'gnus-article-buttons)
 436
 437 (defcustom gnus-signature-face 'gnus-signature-face
 438   "Face used for highlighting a signature in the article buffer.
 439 Obsolete; use the face `gnus-signature-face' for customizations instead."
 440   :type 'face
 441   :group 'gnus-article-highlight
 442   :group 'gnus-article-signature)
 443
 444 (defface gnus-signature-face
 445   '((((type x))
 446      (:italic t)))
 447   "Face used for highlighting a signature in the article buffer."
 448   :group 'gnus-article-highlight
 449   :group 'gnus-article-signature)
 450
 451 (defface gnus-header-from-face
 452   '((((class color)
 453       (background dark))
 454      (:foreground "spring green"))
 455     (((class color)
 456       (background light))
 457      (:foreground "red3"))
 458     (t
 459      (:italic t)))
 460   "Face used for displaying from headers."
 461   :group 'gnus-article-headers
 462   :group 'gnus-article-highlight)
 463
 464 (defface gnus-header-subject-face
 465   '((((class color)
 466       (background dark))
 467      (:foreground "SeaGreen3"))
 468     (((class color)
 469       (background light))
 470      (:foreground "red4"))
 471     (t
 472      (:bold t :italic t)))
 473   "Face used for displaying subject headers."
 474   :group 'gnus-article-headers
 475   :group 'gnus-article-highlight)
 476
 477 (defface gnus-header-newsgroups-face
 478   '((((class color)
 479       (background dark))
 480      (:foreground "yellow" :italic t))
 481     (((class color)
 482       (background light))
 483      (:foreground "MidnightBlue" :italic t))
 484     (t
 485      (:italic t)))
 486   "Face used for displaying newsgroups headers."
 487   :group 'gnus-article-headers
 488   :group 'gnus-article-highlight)
 489
 490 (defface gnus-header-name-face
 491   '((((class color)
 492       (background dark))
 493      (:foreground "SeaGreen"))
 494     (((class color)
 495       (background light))
 496      (:foreground "maroon"))
 497     (t
 498      (:bold t)))
 499   "Face used for displaying header names."
 500   :group 'gnus-article-headers
 501   :group 'gnus-article-highlight)
 502
 503 (defface gnus-header-content-face
 504   '((((class color)
 505       (background dark))
 506      (:foreground "forest green" :italic t))
 507     (((class color)
 508       (background light))
 509      (:foreground "indianred4" :italic t))
 510     (t
 511      (:italic t)))  "Face used for displaying header content."
 512   :group 'gnus-article-headers
 513   :group 'gnus-article-highlight)
 514
 515 (defcustom gnus-header-face-alist
 516   '(("From" nil gnus-header-from-face)
 517     ("Subject" nil gnus-header-subject-face)
 518     ("Newsgroups:.*," nil gnus-header-newsgroups-face)
 519     ("" gnus-header-name-face gnus-header-content-face))
 520   "*Controls highlighting of article header.
 521
 522 An alist of the form (HEADER NAME CONTENT).
 523
 524 HEADER is a regular expression which should match the name of an
 525 header header and NAME and CONTENT are either face names or nil.
 526
 527 The name of each header field will be displayed using the face
 528 specified by the first element in the list where HEADER match the
 529 header name and NAME is non-nil.  Similarly, the content will be
 530 displayed by the first non-nil matching CONTENT face."
 531   :group 'gnus-article-headers
 532   :group 'gnus-article-highlight
 533   :type '(repeat (list (regexp :tag "Header")
 534                        (choice :tag "Name"
 535                                (item :tag "skip" nil)
 536                                (face :value default))
 537                        (choice :tag "Content"
 538                                (item :tag "skip" nil)
 539                                (face :value default)))))
 540
 541 (defcustom gnus-article-decode-hook
 542   '(article-decode-charset article-decode-encoded-words)
 543   "*Hook run to decode charsets in articles."
 544   :group 'gnus-article-headers
 545   :type 'hook)
 546
 547 (defcustom gnus-display-mime-function 'gnus-display-mime
 548   "Function to display MIME articles."
 549   :group 'gnus-article-mime
 550   :type 'function)
 551
 552 (defvar gnus-decode-header-function 'mail-decode-encoded-word-region
 553   "Function used to decode headers.")
 554
 555 (defvar gnus-article-dumbquotes-map
 556   '(("\202" ",")
 557     ("\203" "f")
 558     ("\204" ",,")
 559     ("\205" "...")
 560     ("\213" "<")
 561     ("\214" "OE")
 562     ("\205" "...")
 563     ("\221" "`")
 564     ("\222" "'")
 565     ("\223" "``")
 566     ("\224" "''")
 567     ("\225" "*")
 568     ("\226" "-")
 569     ("\227" "-")
 570     ("\231" "(TM)")
 571     ("\233" ">")
 572     ("\234" "oe")
 573     ("\264" "'"))
 574   "Table for MS-to-Latin1 translation.")
 575
 576 (defcustom gnus-ignored-mime-types nil
 577   "List of MIME types that should be ignored by Gnus."
 578   :group 'gnus-article-mime
 579   :type '(repeat regexp))
 580
 581 (defcustom gnus-unbuttonized-mime-types '(".*/.*")
 582   "List of MIME types that should not be given buttons when rendered."
 583   :group 'gnus-article-mime
 584   :type '(repeat regexp))
 585
 586 (defcustom gnus-treat-body-highlight-signature t
 587   "Highlight the signature."
 588   :group 'gnus-article
 589   :type '(choice (const :tag "Off" nil)
 590                  (const :tag "On" t)
 591                  (const :tag "Last" last)
 592                  (integer :tag "Less")
 593                  (sexp :tag "Predicate")))
 594
 595 (defcustom gnus-article-mime-part-function nil
 596   "Function called with a MIME handle as the argument."
 597   :group 'gnus-article-mime
 598   :type 'function)
 599
 600 ;;; Internal variables
 601
 602 (defvar gnus-article-mime-handle-alist-1 nil)
 603 (defvar gnus-treatment-function-alist
 604   '((gnus-treat-body-highlight-signature gnus-article-highlight-signature nil)
 605     ))
 606
 607 (defvar gnus-article-mime-handle-alist nil)
 608 (defvar article-lapsed-timer nil)
 609 (defvar gnus-article-current-summary nil)
 610
 611 (defvar gnus-article-mode-syntax-table
 612   (let ((table (copy-syntax-table text-mode-syntax-table)))
 613     (modify-syntax-entry ?- "w" table)
 614     (modify-syntax-entry ?> ")" table)
 615     (modify-syntax-entry ?< "(" table)
 616     table)
 617   "Syntax table used in article mode buffers.
 618 Initialized from `text-mode-syntax-table.")
 619
 620 (defvar gnus-save-article-buffer nil)
 621
 622 (defvar gnus-article-mode-line-format-alist
 623   (nconc '((?w (gnus-article-wash-status) ?s)
 624            (?m (gnus-article-mime-part-status) ?s))
 625          gnus-summary-mode-line-format-alist))
 626
 627 (defvar gnus-number-of-articles-to-be-saved nil)
 628
 629 (defvar gnus-inhibit-hiding nil)
 630
 631 (defsubst gnus-article-hide-text (b e props)
 632   "Set text PROPS on the B to E region, extending `intangible' 1 past B."
 633   (add-text-properties b e props)
 634   (when (memq 'intangible props)
 635     (put-text-property
 636      (max (1- b) (point-min))
 637      b 'intangible (cddr (memq 'intangible props)))))
 638
 639 (defsubst gnus-article-unhide-text (b e)
 640   "Remove hidden text properties from region between B and E."
 641   (remove-text-properties b e gnus-hidden-properties)
 642   (when (memq 'intangible gnus-hidden-properties)
 643     (put-text-property (max (1- b) (point-min))
 644                        b 'intangible nil)))
 645
 646 (defun gnus-article-hide-text-type (b e type)
 647   "Hide text of TYPE between B and E."
 648   (gnus-article-hide-text
 649    b e (cons 'article-type (cons type gnus-hidden-properties))))
 650
 651 (defun gnus-article-unhide-text-type (b e type)
 652   "Unhide text of TYPE between B and E."
 653   (remove-text-properties
 654    b e (cons 'article-type (cons type gnus-hidden-properties)))
 655   (when (memq 'intangible gnus-hidden-properties)
 656     (put-text-property (max (1- b) (point-min))
 657                        b 'intangible nil)))
 658
 659 (defun gnus-article-hide-text-of-type (type)
 660   "Hide text of TYPE in the current buffer."
 661   (save-excursion
 662     (let ((b (point-min))
 663           (e (point-max)))
 664       (while (setq b (text-property-any b e 'article-type type))
 665         (add-text-properties b (incf b) gnus-hidden-properties)))))
 666
 667 (defun gnus-article-delete-text-of-type (type)
 668   "Delete text of TYPE in the current buffer."
 669   (save-excursion
 670     (let ((b (point-min)))
 671       (while (setq b (text-property-any b (point-max) 'article-type type))
 672         (delete-region
 673          b (or (text-property-not-all b (point-max) 'article-type type)
 674                (point-max)))))))
 675
 676 (defun gnus-article-delete-invisible-text ()
 677   "Delete all invisible text in the current buffer."
 678   (save-excursion
 679     (let ((b (point-min)))
 680       (while (setq b (text-property-any b (point-max) 'invisible t))
 681         (delete-region
 682          b (or (text-property-not-all b (point-max) 'invisible t)
 683                (point-max)))))))
 684
 685 (defun gnus-article-text-type-exists-p (type)
 686   "Say whether any text of type TYPE exists in the buffer."
 687   (text-property-any (point-min) (point-max) 'article-type type))
 688
 689 (defsubst gnus-article-header-rank ()
 690   "Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
 691   (let ((list gnus-sorted-header-list)
 692         (i 0))
 693     (while list
 694       (when (looking-at (car list))
 695         (setq list nil))
 696       (setq list (cdr list))
 697       (incf i))
 698     i))
 699
 700 (defun article-hide-headers (&optional arg delete)
 701   "Toggle whether to hide unwanted headers and possibly sort them as well.
 702 If given a negative prefix, always show; if given a positive prefix,
 703 always hide."
 704   (interactive (gnus-article-hidden-arg))
 705   (current-buffer)
 706   (if (gnus-article-check-hidden-text 'headers arg)
 707       ;; Show boring headers as well.
 708       (gnus-article-show-hidden-text 'boring-headers)
 709     ;; This function might be inhibited.
 710     (unless gnus-inhibit-hiding
 711       (save-excursion
 712         (save-restriction
 713           (let ((buffer-read-only nil)
 714                 (case-fold-search t)
 715                 (props (nconc (list 'article-type 'headers)
 716                               gnus-hidden-properties))
 717                 (max (1+ (length gnus-sorted-header-list)))
 718                 (ignored (when (not gnus-visible-headers)
 719                            (cond ((stringp gnus-ignored-headers)
 720                                   gnus-ignored-headers)
 721                                  ((listp gnus-ignored-headers)
 722                                   (mapconcat 'identity gnus-ignored-headers
 723                                              "\\|")))))
 724                 (visible
 725                  (cond ((stringp gnus-visible-headers)
 726                         gnus-visible-headers)
 727                        ((and gnus-visible-headers
 728                              (listp gnus-visible-headers))
 729                         (mapconcat 'identity gnus-visible-headers "\\|"))))
 730                 (inhibit-point-motion-hooks t)
 731                 beg)
 732             ;; First we narrow to just the headers.
 733             (widen)
 734             (goto-char (point-min))
 735             ;; Hide any "From " lines at the beginning of (mail) articles.
 736             (while (looking-at "From ")
 737               (forward-line 1))
 738             (unless (bobp)
 739               (if delete
 740                   (delete-region (point-min) (point))
 741                 (gnus-article-hide-text (point-min) (point) props)))
 742             ;; Then treat the rest of the header lines.
 743             (narrow-to-region
 744              (point)
 745              (if (search-forward "\n\n" nil t) ; if there's a body
 746                  (progn (forward-line -1) (point))
 747                (point-max)))
 748             ;; Then we use the two regular expressions
 749             ;; `gnus-ignored-headers' and `gnus-visible-headers' to
 750             ;; select which header lines is to remain visible in the
 751             ;; article buffer.
 752             (goto-char (point-min))
 753             (while (re-search-forward "^[^ \t]*:" nil t)
 754               (beginning-of-line)
 755               ;; Mark the rank of the header.
 756               (put-text-property
 757                (point) (1+ (point)) 'message-rank
 758                (if (or (and visible (looking-at visible))
 759                        (and ignored
 760                             (not (looking-at ignored))))
 761                    (gnus-article-header-rank)
 762                  (+ 2 max)))
 763               (forward-line 1))
 764             (message-sort-headers-1)
 765             (when (setq beg (text-property-any
 766                              (point-min) (point-max) 'message-rank (+ 2 max)))
 767               ;; We make the unwanted headers invisible.
 768               (if delete
 769                   (delete-region beg (point-max))
 770                 ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
 771                 (gnus-article-hide-text-type beg (point-max) 'headers))
 772               ;; Work around XEmacs lossage.
 773               (put-text-property (point-min) beg 'invisible nil))))))))
 774
 775 (defun article-hide-boring-headers (&optional arg)
 776   "Toggle hiding of headers that aren't very interesting.
 777 If given a negative prefix, always show; if given a positive prefix,
 778 always hide."
 779   (interactive (gnus-article-hidden-arg))
 780   (when (and (not (gnus-article-check-hidden-text 'boring-headers arg))
 781              (not gnus-show-all-headers))
 782     (save-excursion
 783       (save-restriction
 784         (let ((buffer-read-only nil)
 785               (list gnus-boring-article-headers)
 786               (inhibit-point-motion-hooks t)
 787               elem)
 788           (nnheader-narrow-to-headers)
 789           (while list
 790             (setq elem (pop list))
 791             (goto-char (point-min))
 792             (cond
 793              ;; Hide empty headers.
 794              ((eq elem 'empty)
 795               (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
 796                 (forward-line -1)
 797                 (gnus-article-hide-text-type
 798                  (progn (beginning-of-line) (point))
 799                  (progn
 800                    (end-of-line)
 801                    (if (re-search-forward "^[^ \t]" nil t)
 802                        (match-beginning 0)
 803                      (point-max)))
 804                  'boring-headers)))
 805              ;; Hide boring Newsgroups header.
 806              ((eq elem 'newsgroups)
 807               (when (equal (gnus-fetch-field "newsgroups")
 808                            (gnus-group-real-name
 809                             (if (boundp 'gnus-newsgroup-name)
 810                                 gnus-newsgroup-name
 811                               "")))
 812                 (gnus-article-hide-header "newsgroups")))
 813              ((eq elem 'followup-to)
 814               (when (equal (message-fetch-field "followup-to")
 815                            (message-fetch-field "newsgroups"))
 816                 (gnus-article-hide-header "followup-to")))
 817              ((eq elem 'reply-to)
 818               (let ((from (message-fetch-field "from"))
 819                     (reply-to (message-fetch-field "reply-to")))
 820                 (when (and
 821                        from reply-to
 822                        (ignore-errors
 823                          (equal
 824                           (nth 1 (mail-extract-address-components from))
 825                           (nth 1 (mail-extract-address-components reply-to)))))
 826                   (gnus-article-hide-header "reply-to"))))
 827              ((eq elem 'date)
 828               (let ((date (message-fetch-field "date")))
 829                 (when (and date
 830                            (< (days-between (current-time-string) date)
 831                               4))
 832                   (gnus-article-hide-header "date"))))
 833              ((eq elem 'long-to)
 834               (let ((to (message-fetch-field "to")))
 835                 (when (> (length to) 1024)
 836                   (gnus-article-hide-header "to"))))
 837              ((eq elem 'many-to)
 838               (let ((to-count 0))
 839                 (goto-char (point-min))
 840                 (while (re-search-forward "^to:" nil t)
 841                   (setq to-count (1+ to-count)))
 842                 (when (> to-count 1)
 843                   (while (> to-count 0)
 844                     (goto-char (point-min))
 845                     (save-restriction
 846                       (re-search-forward "^to:" nil nil to-count)
 847                       (forward-line -1)
 848                       (narrow-to-region (point) (point-max))
 849                       (gnus-article-hide-header "to"))
 850                     (setq to-count (1- to-count)))))))))))))
 851
 852 (defun gnus-article-hide-header (header)
 853   (save-excursion
 854     (goto-char (point-min))
 855     (when (re-search-forward (concat "^" header ":") nil t)
 856       (gnus-article-hide-text-type
 857        (progn (beginning-of-line) (point))
 858        (progn
 859          (end-of-line)
 860          (if (re-search-forward "^[^ \t]" nil t)
 861              (match-beginning 0)
 862            (point-max)))
 863        'boring-headers))))
 864
 865 (defun article-treat-dumbquotes ()
 866   "Translate M******** sm*rtq**t*s into proper text."
 867   (interactive)
 868   (article-translate-strings gnus-article-dumbquotes-map))
 869
 870 (defun article-translate-characters (from to)
 871   "Translate all characters in the body of the article according to FROM and TO.
 872 FROM is a string of characters to translate from; to is a string of
 873 characters to translate to."
 874   (save-excursion
 875     (when (article-goto-body)
 876       (let ((buffer-read-only nil)
 877             (x (make-string 225 ?x))
 878             (i -1))
 879         (while (< (incf i) (length x))
 880           (aset x i i))
 881         (setq i 0)
 882         (while (< i (length from))
 883           (aset x (aref from i) (aref to i))
 884           (incf i))
 885         (translate-region (point) (point-max) x)))))
 886
 887 (defun article-translate-strings (map)
 888   "Translate all string in the body of the article according to MAP.
 889 MAP is an alist where the elements are on the form (\"from\" \"to\")."
 890   (save-excursion
 891     (when (article-goto-body)
 892       (let ((buffer-read-only nil)
 893             elem)
 894         (while (setq elem (pop map))
 895           (save-excursion
 896             (while (search-forward (car elem) nil t)
 897               (replace-match (cadr elem)))))))))
 898
 899 (defun article-treat-overstrike ()
 900   "Translate overstrikes into bold text."
 901   (interactive)
 902   (save-excursion
 903     (when (article-goto-body)
 904       (let ((buffer-read-only nil))
 905         (while (search-forward "\b" nil t)
 906           (let ((next (char-after))
 907                 (previous (char-after (- (point) 2))))
 908             ;; We do the boldification/underlining by hiding the
 909             ;; overstrikes and putting the proper text property
 910             ;; on the letters.
 911             (cond
 912              ((eq next previous)
 913               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
 914               (put-text-property (point) (1+ (point)) 'face 'bold))
 915              ((eq next ?_)
 916               (gnus-article-hide-text-type
 917                (1- (point)) (1+ (point)) 'overstrike)
 918               (put-text-property
 919                (- (point) 2) (1- (point)) 'face 'underline))
 920              ((eq previous ?_)
 921               (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike)
 922               (put-text-property
 923                (point) (1+ (point)) 'face 'underline)))))))))
 924
 925 (defun article-fill ()
 926   "Format too long lines."
 927   (interactive)
 928   (save-excursion
 929     (let ((buffer-read-only nil))
 930       (widen)
 931       (article-goto-body)
 932       (end-of-line 1)
 933       (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
 934             (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
 935             (adaptive-fill-mode t))
 936         (while (not (eobp))
 937           (and (>= (current-column) (min fill-column (window-width)))
 938                (/= (preceding-char) ?:)
 939                (fill-paragraph nil))
 940           (end-of-line 2))))))
 941
 942 (defun article-remove-cr ()
 943   "Translate CRLF pairs into LF, and then CR into LF.."
 944   (interactive)
 945   (save-excursion
 946     (let ((buffer-read-only nil))
 947       (goto-char (point-min))
 948       (while (search-forward "\r$" nil t)
 949         (replace-match "" t t))
 950       (goto-char (point-min))
 951       (while (search-forward "\r" nil t)
 952         (replace-match "\n" t t)))))
 953
 954 (defun article-remove-trailing-blank-lines ()
 955   "Remove all trailing blank lines from the article."
 956   (interactive)
 957   (save-excursion
 958     (let ((buffer-read-only nil))
 959       (goto-char (point-max))
 960       (delete-region
 961        (point)
 962        (progn
 963          (while (and (not (bobp))
 964                      (looking-at "^[ \t]*$")
 965                      (not (gnus-annotation-in-region-p
 966                            (point) (gnus-point-at-eol))))
 967            (forward-line -1))
 968          (forward-line 1)
 969          (point))))))
 970
 971 (defun article-display-x-face (&optional force)
 972   "Look for an X-Face header and display it if present."
 973   (interactive (list 'force))
 974   (save-excursion
 975     ;; Delete the old process, if any.
 976     (when (process-status "article-x-face")
 977       (delete-process "article-x-face"))
 978     (let ((inhibit-point-motion-hooks t)
 979           (case-fold-search t)
 980           from last)
 981       (save-restriction
 982         (nnheader-narrow-to-headers)
 983         (setq from (message-fetch-field "from"))
 984         (goto-char (point-min))
 985         (while (and gnus-article-x-face-command
 986                     (not last)
 987                     (or force
 988                         ;; Check whether this face is censored.
 989                         (not gnus-article-x-face-too-ugly)
 990                         (and gnus-article-x-face-too-ugly from
 991                              (not (string-match gnus-article-x-face-too-ugly
 992                                                 from))))
 993                     ;; Has to be present.
 994                     (re-search-forward "^X-Face: " nil t))
 995           ;; This used to try to do multiple faces (`while' instead of
 996           ;; `when' above), but (a) sending multiple EOFs to xv doesn't
 997           ;; work (b) it can crash some versions of Emacs (c) are
 998           ;; multiple faces really something to encourage?
 999           (when (stringp gnus-article-x-face-command)
1000             (setq last t))
1001           ;; We now have the area of the buffer where the X-Face is stored.
1002           (save-excursion
1003             (let ((beg (point))
1004                   (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
1005               ;; We display the face.
1006               (if (symbolp gnus-article-x-face-command)
1007                   ;; The command is a lisp function, so we call it.
1008                   (if (gnus-functionp gnus-article-x-face-command)
1009                       (funcall gnus-article-x-face-command beg end)
1010                     (error "%s is not a function" gnus-article-x-face-command))
1011                 ;; The command is a string, so we interpret the command
1012                 ;; as a, well, command, and fork it off.
1013                 (let ((process-connection-type nil))
1014                   (process-kill-without-query
1015                    (start-process
1016                     "article-x-face" nil shell-file-name shell-command-switch
1017                     gnus-article-x-face-command))
1018                   (process-send-region "article-x-face" beg end)
1019                   (process-send-eof "article-x-face"))))))))))
1020
1021 (defun article-decode-mime-words ()
1022   "Decode all MIME-encoded words in the article."
1023   (interactive)
1024   (save-excursion
1025     (set-buffer gnus-article-buffer)
1026     (let ((inhibit-point-motion-hooks t)
1027           buffer-read-only
1028           (rfc2047-default-charset gnus-newsgroup-default-charset)
1029           (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
1030       (mail-decode-encoded-word-region (point-min) (point-max)))))
1031
1032 (defun article-decode-charset (&optional prompt)
1033   "Decode charset-encoded text in the article.
1034 If PROMPT (the prefix), prompt for a coding system to use."
1035   (interactive "P")
1036   (save-excursion
1037     (save-restriction
1038       (message-narrow-to-head)
1039       (let* ((inhibit-point-motion-hooks t)
1040              (case-fold-search t)
1041              (ct (message-fetch-field "Content-Type" t))
1042              (cte (message-fetch-field "Content-Transfer-Encoding" t))
1043              (ctl (and ct (condition-case ()
1044                               (mail-header-parse-content-type ct)
1045                             (error nil))))
1046              (charset (cond
1047                        (prompt
1048                         (mm-read-coding-system "Charset to decode: "))
1049                        (ctl
1050                         (mail-content-type-get ctl 'charset))))
1051              (rfc2047-default-charset gnus-newsgroup-default-charset)
1052              (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced)
1053              buffer-read-only)
1054         (goto-char (point-max))
1055         (widen)
1056         (forward-line 1)
1057         (narrow-to-region (point) (point-max))
1058         (when (and (or (not ctl)
1059                        (equal (car ctl) "text/plain"))
1060                    (not (mm-uu-test)))
1061           (mm-decode-body
1062            charset (and cte (intern (downcase
1063                                      (gnus-strip-whitespace cte))))
1064            (car ctl)))))))
1065
1066 (defun article-decode-encoded-words ()
1067   "Remove encoded-word encoding from headers."
1068   (let ((inhibit-point-motion-hooks t)
1069         buffer-read-only
1070         (rfc2047-default-charset gnus-newsgroup-default-charset)
1071         (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
1072     (save-restriction
1073       (message-narrow-to-head)
1074       (funcall gnus-decode-header-function (point-min) (point-max)))))
1075
1076 (defun article-de-quoted-unreadable (&optional force)
1077   "Translate a quoted-printable-encoded article.
1078 If FORCE, decode the article whether it is marked as quoted-printable
1079 or not."
1080   (interactive (list 'force))
1081   (save-excursion
1082     (let ((buffer-read-only nil)
1083           (type (gnus-fetch-field "content-transfer-encoding"))
1084           (charset
1085            (or gnus-newsgroup-default-charset mm-default-coding-system))
1086           (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
1087       (when (or force
1088                 (and type (string-match "quoted-printable" (downcase type))))
1089         (article-goto-body)
1090         (save-restriction
1091           (narrow-to-region (point) (point-max))
1092           (quoted-printable-decode-region (point-min) (point-max))
1093           (when charset
1094             (mm-decode-body charset)))))))
1095
1096 (defun article-hide-pgp (&optional arg)
1097   "Toggle hiding of any PGP headers and signatures in the current article.
1098 If given a negative prefix, always show; if given a positive prefix,
1099 always hide."
1100   (interactive (gnus-article-hidden-arg))
1101   (unless (gnus-article-check-hidden-text 'pgp arg)
1102     (save-excursion
1103       (let ((inhibit-point-motion-hooks t)
1104             buffer-read-only beg end)
1105         (widen)
1106         (goto-char (point-min))
1107         ;; Hide the "header".
1108         (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
1109           (delete-region (1+ (match-beginning 0)) (match-end 0))
1110           ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
1111           (when (looking-at "Hash:.*$")
1112             (delete-region (point) (1+ (gnus-point-at-eol))))
1113           (setq beg (point))
1114           ;; Hide the actual signature.
1115           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
1116                (setq end (1+ (match-beginning 0)))
1117                (delete-region
1118                 end
1119                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
1120                     (match-end 0)
1121                   ;; Perhaps we shouldn't hide to the end of the buffer
1122                   ;; if there is no end to the signature?
1123                   (point-max))))
1124           ;; Hide "- " PGP quotation markers.
1125           (when (and beg end)
1126             (narrow-to-region beg end)
1127             (goto-char (point-min))
1128             (while (re-search-forward "^- " nil t)
1129               (delete-region
1130                (match-beginning 0) (match-end 0)))
1131             (widen))
1132           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
1133
1134 (defun article-hide-pem (&optional arg)
1135   "Toggle hiding of any PEM headers and signatures in the current article.
1136 If given a negative prefix, always show; if given a positive prefix,
1137 always hide."
1138   (interactive (gnus-article-hidden-arg))
1139   (unless (gnus-article-check-hidden-text 'pem arg)
1140     (save-excursion
1141       (let (buffer-read-only end)
1142         (widen)
1143         (goto-char (point-min))
1144         ;; hide the horrendously ugly "header".
1145         (and (search-forward "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
1146                              nil
1147                              t)
1148              (setq end (1+ (match-beginning 0)))
1149              (gnus-article-hide-text-type
1150               end
1151               (if (search-forward "\n\n" nil t)
1152                   (match-end 0)
1153                 (point-max))
1154               'pem))
1155         ;; hide the trailer as well
1156         (and (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
1157                              nil
1158                              t)
1159              (gnus-article-hide-text-type
1160               (match-beginning 0) (match-end 0) 'pem))))))
1161
1162 (defun article-hide-signature (&optional arg)
1163   "Hide the signature in the current article.
1164 If given a negative prefix, always show; if given a positive prefix,
1165 always hide."
1166   (interactive (gnus-article-hidden-arg))
1167   (unless (gnus-article-check-hidden-text 'signature arg)
1168     (save-excursion
1169       (save-restriction
1170         (let ((buffer-read-only nil))
1171           (when (gnus-article-narrow-to-signature)
1172             (gnus-article-hide-text-type
1173              (point-min) (point-max) 'signature)))))))
1174
1175 (defun article-strip-leading-blank-lines ()
1176   "Remove all blank lines from the beginning of the article."
1177   (interactive)
1178   (save-excursion
1179     (let ((inhibit-point-motion-hooks t)
1180           buffer-read-only)
1181       (when (article-goto-body)
1182         (while (and (not (eobp))
1183                     (looking-at "[ \t]*$"))
1184           (gnus-delete-line))))))
1185
1186 (defun article-goto-body ()
1187   "Place point at the start of the body."
1188   (goto-char (point-min))
1189   (if (search-forward "\n\n" nil t)
1190       t
1191     (goto-char (point-max))
1192     nil))
1193
1194 (defun article-strip-multiple-blank-lines ()
1195   "Replace consecutive blank lines with one empty line."
1196   (interactive)
1197   (save-excursion
1198     (let ((inhibit-point-motion-hooks t)
1199           buffer-read-only)
1200       ;; First make all blank lines empty.
1201       (article-goto-body)
1202       (while (re-search-forward "^[ \t]+$" nil t)
1203         (unless (gnus-annotation-in-region-p
1204                  (match-beginning 0) (match-end 0))
1205           (replace-match "" nil t)))
1206       ;; Then replace multiple empty lines with a single empty line.
1207       (article-goto-body)
1208       (while (re-search-forward "\n\n\n+" nil t)
1209         (unless (gnus-annotation-in-region-p
1210                  (match-beginning 0) (match-end 0))
1211           (replace-match "\n\n" t t))))))
1212
1213 (defun article-strip-leading-space ()
1214   "Remove all white space from the beginning of the lines in the article."
1215   (interactive)
1216   (save-excursion
1217     (let ((inhibit-point-motion-hooks t)
1218           buffer-read-only)
1219       (article-goto-body)
1220       (while (re-search-forward "^[ \t]+" nil t)
1221         (replace-match "" t t)))))
1222
1223 (defun article-strip-trailing-space ()
1224   "Remove all white space from the end of the lines in the article."
1225   (interactive)
1226   (save-excursion
1227     (let ((inhibit-point-motion-hooks t)
1228           buffer-read-only)
1229       (article-goto-body)
1230       (while (re-search-forward "[ \t]+$" nil t)
1231         (replace-match "" t t)))))
1232
1233 (defun article-strip-blank-lines ()
1234   "Strip leading, trailing and multiple blank lines."
1235   (interactive)
1236   (article-strip-leading-blank-lines)
1237   (article-remove-trailing-blank-lines)
1238   (article-strip-multiple-blank-lines))
1239
1240 (defun article-strip-all-blank-lines ()
1241   "Strip all blank lines."
1242   (interactive)
1243   (save-excursion
1244     (let ((inhibit-point-motion-hooks t)
1245           buffer-read-only)
1246       (article-goto-body)
1247       (while (re-search-forward "^[ \t]*\n" nil t)
1248         (replace-match "" t t)))))
1249
1250 (defun gnus-article-narrow-to-signature ()
1251   "Narrow to the signature; return t if a signature is found, else nil."
1252   (widen)
1253   (let ((inhibit-point-motion-hooks t))
1254     (when (gnus-article-search-signature)
1255       (forward-line 1)
1256       ;; Check whether we have some limits to what we consider
1257       ;; to be a signature.
1258       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
1259                       (list gnus-signature-limit)))
1260             limit limited)
1261         (while (setq limit (pop limits))
1262           (if (or (and (integerp limit)
1263                        (< (- (point-max) (point)) limit))
1264                   (and (floatp limit)
1265                        (< (count-lines (point) (point-max)) limit))
1266                   (and (gnus-functionp limit)
1267                        (funcall limit))
1268                   (and (stringp limit)
1269                        (not (re-search-forward limit nil t))))
1270               ()                        ; This limit did not succeed.
1271             (setq limited t
1272                   limits nil)))
1273         (unless limited
1274           (narrow-to-region (point) (point-max))
1275           t)))))
1276
1277 (defun gnus-article-search-signature ()
1278   "Search the current buffer for the signature separator.
1279 Put point at the beginning of the signature separator."
1280   (let ((cur (point)))
1281     (goto-char (point-max))
1282     (if (if (stringp gnus-signature-separator)
1283             (re-search-backward gnus-signature-separator nil t)
1284           (let ((seps gnus-signature-separator))
1285             (while (and seps
1286                         (not (re-search-backward (car seps) nil t)))
1287               (pop seps))
1288             seps))
1289         t
1290       (goto-char cur)
1291       nil)))
1292
1293 (eval-and-compile
1294   (autoload 'w3-display "w3-parse")
1295   (autoload 'w3-do-setup "w3" "" t)
1296   (autoload 'w3-region "w3-display" "" t))
1297
1298 (defun gnus-article-treat-html ()
1299   "Render HTML."
1300   (interactive)
1301   (let ((cbuf (current-buffer)))
1302     (set-buffer gnus-article-buffer)
1303     (let (buf buffer-read-only b e)
1304       (w3-do-setup)
1305       (goto-char (point-min))
1306       (narrow-to-region
1307        (if (search-forward "\n\n" nil t)
1308            (setq b (point))
1309          (point-max))
1310        (setq e (point-max)))
1311       (with-temp-buffer
1312         (insert-buffer-substring gnus-article-buffer b e)
1313         (require 'url)
1314         (save-window-excursion
1315           (w3-region (point-min) (point-max))
1316           (setq buf (buffer-substring-no-properties (point-min) (point-max)))))
1317       (when buf
1318         (delete-region (point-min) (point-max))
1319         (insert buf))
1320       (widen)
1321       (goto-char (point-min))
1322       (set-window-start (get-buffer-window (current-buffer)) (point-min))
1323       (set-buffer cbuf))))
1324
1325 (defun gnus-article-hidden-arg ()
1326   "Return the current prefix arg as a number, or 0 if no prefix."
1327   (list (if current-prefix-arg
1328             (prefix-numeric-value current-prefix-arg)
1329           0)))
1330
1331 (defun gnus-article-check-hidden-text (type arg)
1332   "Return nil if hiding is necessary.
1333 Arg can be nil or a number.  Nil and positive means hide, negative
1334 means show, 0 means toggle."
1335   (save-excursion
1336     (save-restriction
1337       (widen)
1338       (let ((hide (gnus-article-hidden-text-p type)))
1339         (cond
1340          ((or (null arg)
1341               (> arg 0))
1342           nil)
1343          ((< arg 0)
1344           (gnus-article-show-hidden-text type))
1345          (t
1346           (if (eq hide 'hidden)
1347               (gnus-article-show-hidden-text type)
1348             nil)))))))
1349
1350 (defun gnus-article-hidden-text-p (type)
1351   "Say whether the current buffer contains hidden text of type TYPE."
1352   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
1353     (while (and pos
1354                 (not (get-text-property pos 'invisible)))
1355       (setq pos
1356             (text-property-any (1+ pos) (point-max) 'article-type type)))
1357     (if pos
1358         'hidden
1359       nil)))
1360
1361 (defun gnus-article-show-hidden-text (type &optional hide)
1362   "Show all hidden text of type TYPE.
1363 If HIDE, hide the text instead."
1364   (save-excursion
1365     (let ((buffer-read-only nil)
1366           (inhibit-point-motion-hooks t)
1367           (end (point-min))
1368           beg)
1369       (while (setq beg (text-property-any end (point-max) 'article-type type))
1370         (goto-char beg)
1371         (setq end (or
1372                    (text-property-not-all beg (point-max) 'article-type type)
1373                    (point-max)))
1374         (if hide
1375             (gnus-article-hide-text beg end gnus-hidden-properties)
1376           (gnus-article-unhide-text beg end))
1377         (goto-char end))
1378       t)))
1379
1380 (defconst article-time-units
1381   `((year . ,(* 365.25 24 60 60))
1382     (week . ,(* 7 24 60 60))
1383     (day . ,(* 24 60 60))
1384     (hour . ,(* 60 60))
1385     (minute . 60)
1386     (second . 1))
1387   "Mapping from time units to seconds.")
1388
1389 (defun article-date-ut (&optional type highlight header)
1390   "Convert DATE date to universal time in the current article.
1391 If TYPE is `local', convert to local time; if it is `lapsed', output
1392 how much time has lapsed since DATE."
1393   (interactive (list 'ut t))
1394   (let* ((header (or header
1395                      (mail-header-date gnus-current-headers)
1396                      (message-fetch-field "date")
1397                      ""))
1398          (date (if (vectorp header) (mail-header-date header)
1399                  header))
1400          (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
1401          (inhibit-point-motion-hooks t)
1402          bface eface newline)
1403     (when (and date (not (string= date "")))
1404       (save-excursion
1405         (save-restriction
1406           (nnheader-narrow-to-headers)
1407           (let ((buffer-read-only nil))
1408             ;; Delete any old Date headers.
1409             (if (re-search-forward date-regexp nil t)
1410                 (progn
1411                   (setq bface (get-text-property (gnus-point-at-bol) 'face)
1412                         eface (get-text-property (1- (gnus-point-at-eol))
1413                                                  'face))
1414                   (delete-region (progn (beginning-of-line) (point))
1415                                  (progn (end-of-line) (point)))
1416                   (beginning-of-line))
1417               (goto-char (point-max))
1418               (setq newline t))
1419             (insert (article-make-date-line date type))
1420             ;; Do highlighting.
1421             (beginning-of-line)
1422             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
1423               (put-text-property (match-beginning 1) (1+ (match-end 1))
1424                                  'face bface)
1425               (put-text-property (match-beginning 2) (match-end 2)
1426                                  'face eface))
1427             (when newline
1428               (end-of-line)
1429               (insert "\n"))))))))
1430
1431 (defun article-make-date-line (date type)
1432   "Return a DATE line of TYPE."
1433   (let ((time (condition-case ()
1434                   (date-to-time date)
1435                 (error '(0 0)))))
1436     (cond
1437      ;; Convert to the local timezone.  We have to slap a
1438      ;; `condition-case' round the calls to the timezone
1439      ;; functions since they aren't particularly resistant to
1440      ;; buggy dates.
1441      ((eq type 'local)
1442       (let ((tz (car (current-time-zone))))
1443         (format "Date: %s %s%04d" (current-time-string time)
1444                 (if (> tz 0) "+" "-") (abs (/ tz 36)))))
1445      ;; Convert to Universal Time.
1446      ((eq type 'ut)
1447       (concat "Date: "
1448               (current-time-string
1449                (let* ((e (parse-time-string date))
1450                      (tm (apply 'encode-time e))
1451                      (ms (car tm))
1452                      (ls (- (cadr tm) (car (current-time-zone)))))
1453                  (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
1454                        ((> ls 65535) (list (1+ ms) (- ls 65536)))
1455                        (t (list ms ls)))))
1456               " UT"))
1457      ;; Get the original date from the article.
1458      ((eq type 'original)
1459       (concat "Date: " (if (string-match "\n+$" date)
1460                            (substring date 0 (match-beginning 0))
1461                          date)))
1462      ;; Let the user define the format.
1463      ((eq type 'user)
1464       (if (gnus-functionp gnus-article-time-format)
1465           (funcall gnus-article-time-format time)
1466         (concat
1467          "Date: "
1468          (format-time-string gnus-article-time-format time))))
1469      ;; ISO 8601.
1470      ((eq type 'iso8601)
1471       (concat
1472        "Date: "
1473        (format-time-string "%Y%M%DT%h%m%s" time)))
1474      ;; Do an X-Sent lapsed format.
1475      ((eq type 'lapsed)
1476       ;; If the date is seriously mangled, the timezone functions are
1477       ;; liable to bug out, so we ignore all errors.
1478       (let* ((now (current-time))
1479              (real-time (subtract-time now time))
1480              (real-sec (and real-time
1481                             (+ (* (float (car real-time)) 65536)
1482                                (cadr real-time))))
1483              (sec (and real-time (abs real-sec)))
1484              num prev)
1485         (cond
1486          ((null real-time)
1487           "X-Sent: Unknown")
1488          ((zerop sec)
1489           "X-Sent: Now")
1490          (t
1491           (concat
1492            "X-Sent: "
1493            ;; This is a bit convoluted, but basically we go
1494            ;; through the time units for years, weeks, etc,
1495            ;; and divide things to see whether that results
1496            ;; in positive answers.
1497            (mapconcat
1498             (lambda (unit)
1499               (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
1500                   ;; The (remaining) seconds are too few to
1501                   ;; be divided into this time unit.
1502                   ""
1503                 ;; It's big enough, so we output it.
1504                 (setq sec (- sec (* num (cdr unit))))
1505                 (prog1
1506                     (concat (if prev ", " "") (int-to-string
1507                                                (floor num))
1508                             " " (symbol-name (car unit))
1509                             (if (> num 1) "s" ""))
1510                   (setq prev t))))
1511             article-time-units "")
1512            ;; If dates are odd, then it might appear like the
1513            ;; article was sent in the future.
1514            (if (> real-sec 0)
1515                " ago"
1516              " in the future"))))))
1517      (t
1518       (error "Unknown conversion type: %s" type)))))
1519
1520 (defun article-date-local (&optional highlight)
1521   "Convert the current article date to the local timezone."
1522   (interactive (list t))
1523   (article-date-ut 'local highlight))
1524
1525 (defun article-date-original (&optional highlight)
1526   "Convert the current article date to what it was originally.
1527 This is only useful if you have used some other date conversion
1528 function and want to see what the date was before converting."
1529   (interactive (list t))
1530   (article-date-ut 'original highlight))
1531
1532 (defun article-date-lapsed (&optional highlight)
1533   "Convert the current article date to time lapsed since it was sent."
1534   (interactive (list t))
1535   (article-date-ut 'lapsed highlight))
1536
1537 (defun article-update-date-lapsed ()
1538   "Function to be run from a timer to update the lapsed time line."
1539   (let (deactivate-mark)
1540     (save-excursion
1541       (ignore-errors
1542         (walk-windows
1543          (lambda (w)
1544            (set-buffer (window-buffer w))
1545            (when (eq major-mode 'gnus-article-mode)
1546              (goto-char (point-min))
1547              (when (re-search-forward "^X-Sent:" nil t)
1548                (article-date-lapsed t)))))))))
1549
1550 (defun gnus-start-date-timer (&optional n)
1551   "Start a timer to update the X-Sent header in the article buffers.
1552 The numerical prefix says how frequently (in seconds) the function
1553 is to run."
1554   (interactive "p")
1555   (unless n
1556     (setq n 1))
1557   (gnus-stop-date-timer)
1558   (setq article-lapsed-timer
1559         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
1560
1561 (defun gnus-stop-date-timer ()
1562   "Stop the X-Sent timer."
1563   (interactive)
1564   (when article-lapsed-timer
1565     (nnheader-cancel-timer article-lapsed-timer)
1566     (setq article-lapsed-timer nil)))
1567
1568 (defun article-date-user (&optional highlight)
1569   "Convert the current article date to the user-defined format.
1570 This format is defined by the `gnus-article-time-format' variable."
1571   (interactive (list t))
1572   (article-date-ut 'user highlight))
1573
1574 (defun article-date-iso8601 (&optional highlight)
1575   "Convert the current article date to ISO8601."
1576   (interactive (list t))
1577   (article-date-ut 'iso8601 highlight))
1578
1579 (defun article-show-all ()
1580   "Show all hidden text in the article buffer."
1581   (interactive)
1582   (save-excursion
1583     (let ((buffer-read-only nil))
1584       (gnus-article-unhide-text (point-min) (point-max)))))
1585
1586 (defun article-emphasize (&optional arg)
1587   "Emphasize text according to `gnus-emphasis-alist'."
1588   (interactive (gnus-article-hidden-arg))
1589   (unless (gnus-article-check-hidden-text 'emphasis arg)
1590     (save-excursion
1591       (let ((alist gnus-emphasis-alist)
1592             (buffer-read-only nil)
1593             (props (append '(article-type emphasis)
1594                            gnus-hidden-properties))
1595             regexp elem beg invisible visible face)
1596         (article-goto-body)
1597         (setq beg (point))
1598         (while (setq elem (pop alist))
1599           (goto-char beg)
1600           (setq regexp (car elem)
1601                 invisible (nth 1 elem)
1602                 visible (nth 2 elem)
1603                 face (nth 3 elem))
1604           (while (re-search-forward regexp nil t)
1605             (when (and (match-beginning visible) (match-beginning invisible))
1606               (gnus-article-hide-text
1607                (match-beginning invisible) (match-end invisible) props)
1608               (gnus-article-unhide-text-type
1609                (match-beginning visible) (match-end visible) 'emphasis)
1610               (gnus-put-text-property-excluding-newlines
1611                (match-beginning visible) (match-end visible) 'face face)
1612               (goto-char (match-end invisible)))))))))
1613
1614 (defvar gnus-summary-article-menu)
1615 (defvar gnus-summary-post-menu)
1616
1617 ;;; Saving functions.
1618
1619 (defun gnus-article-save (save-buffer file &optional num)
1620   "Save the currently selected article."
1621   (unless gnus-save-all-headers
1622     ;; Remove headers according to `gnus-saved-headers'.
1623     (let ((gnus-visible-headers
1624            (or gnus-saved-headers gnus-visible-headers))
1625           (gnus-article-buffer save-buffer))
1626       (save-excursion
1627         (set-buffer save-buffer)
1628         (article-hide-headers 1 t))))
1629   (save-window-excursion
1630     (if (not gnus-default-article-saver)
1631         (error "No default saver is defined")
1632       ;; !!! Magic!  The saving functions all save
1633       ;; `gnus-save-article-buffer' (or so they think), but we
1634       ;; bind that variable to our save-buffer.
1635       (set-buffer gnus-article-buffer)
1636       (let* ((gnus-save-article-buffer save-buffer)
1637              (filename
1638               (cond
1639                ((not gnus-prompt-before-saving) 'default)
1640                ((eq gnus-prompt-before-saving 'always) nil)
1641                (t file)))
1642              (gnus-number-of-articles-to-be-saved
1643               (when (eq gnus-prompt-before-saving t)
1644                 num)))                  ; Magic
1645         (set-buffer gnus-article-current-summary)
1646         (funcall gnus-default-article-saver filename)))))
1647
1648 (defun gnus-read-save-file-name (prompt &optional filename
1649                                         function group headers variable)
1650   (let ((default-name
1651           (funcall function group headers (symbol-value variable)))
1652         result)
1653     (setq
1654      result
1655      (cond
1656       ((eq filename 'default)
1657        default-name)
1658       ((eq filename t)
1659        default-name)
1660       (filename filename)
1661       (t
1662        (let* ((split-name (gnus-get-split-value gnus-split-methods))
1663               (prompt
1664                (format prompt
1665                        (if (and gnus-number-of-articles-to-be-saved
1666                                 (> gnus-number-of-articles-to-be-saved 1))
1667                            (format "these %d articles"
1668                                    gnus-number-of-articles-to-be-saved)
1669                          "this article")))
1670               (file
1671                ;; Let the split methods have their say.
1672                (cond
1673                 ;; No split name was found.
1674                 ((null split-name)
1675                  (read-file-name
1676                   (concat prompt " (default "
1677                           (file-name-nondirectory default-name) ") ")
1678                   (file-name-directory default-name)
1679                   default-name))
1680                 ;; A single group name is returned.
1681                 ((stringp split-name)
1682                  (setq default-name
1683                        (funcall function split-name headers
1684                                 (symbol-value variable)))
1685                  (read-file-name
1686                   (concat prompt " (default "
1687                           (file-name-nondirectory default-name) ") ")
1688                   (file-name-directory default-name)
1689                   default-name))
1690                 ;; A single split name was found
1691                 ((= 1 (length split-name))
1692                  (let* ((name (expand-file-name
1693                                (car split-name) gnus-article-save-directory))
1694                         (dir (cond ((file-directory-p name)
1695                                     (file-name-as-directory name))
1696                                    ((file-exists-p name) name)
1697                                    (t gnus-article-save-directory))))
1698                    (read-file-name
1699                     (concat prompt " (default " name ") ")
1700                     dir name)))
1701                 ;; A list of splits was found.
1702                 (t
1703                  (setq split-name (nreverse split-name))
1704                  (let (result)
1705                    (let ((file-name-history
1706                           (nconc split-name file-name-history)))
1707                      (setq result
1708                            (expand-file-name
1709                             (read-file-name
1710                              (concat prompt " (`M-p' for defaults) ")
1711                              gnus-article-save-directory
1712                              (car split-name))
1713                             gnus-article-save-directory)))
1714                    (car (push result file-name-history)))))))
1715          ;; Create the directory.
1716          (gnus-make-directory (file-name-directory file))
1717          ;; If we have read a directory, we append the default file name.
1718          (when (file-directory-p file)
1719            (setq file (concat (file-name-as-directory file)
1720                               (file-name-nondirectory default-name))))
1721          ;; Possibly translate some characters.
1722          (nnheader-translate-file-chars file)))))
1723     (gnus-make-directory (file-name-directory result))
1724     (set variable result)))
1725
1726 (defun gnus-article-archive-name (group)
1727   "Return the first instance of an \"Archive-name\" in the current buffer."
1728   (let ((case-fold-search t))
1729     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
1730       (nnheader-concat gnus-article-save-directory
1731                        (match-string 1)))))
1732
1733 (defun gnus-article-nndoc-name (group)
1734   "If GROUP is an nndoc group, return the name of the parent group."
1735   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
1736     (gnus-group-get-parameter group 'save-article-group)))
1737
1738 (defun gnus-summary-save-in-rmail (&optional filename)
1739   "Append this article to Rmail file.
1740 Optional argument FILENAME specifies file name.
1741 Directory to save to is default to `gnus-article-save-directory'."
1742   (setq filename (gnus-read-save-file-name
1743                   "Save %s in rmail file:" filename
1744                   gnus-rmail-save-name gnus-newsgroup-name
1745                   gnus-current-headers 'gnus-newsgroup-last-rmail))
1746   (gnus-eval-in-buffer-window gnus-save-article-buffer
1747     (save-excursion
1748       (save-restriction
1749         (widen)
1750         (gnus-output-to-rmail filename))))
1751   filename)
1752
1753 (defun gnus-summary-save-in-mail (&optional filename)
1754   "Append this article to Unix mail file.
1755 Optional argument FILENAME specifies file name.
1756 Directory to save to is default to `gnus-article-save-directory'."
1757   (setq filename (gnus-read-save-file-name
1758                   "Save %s in Unix mail file:" filename
1759                   gnus-mail-save-name gnus-newsgroup-name
1760                   gnus-current-headers 'gnus-newsgroup-last-mail))
1761   (gnus-eval-in-buffer-window gnus-save-article-buffer
1762     (save-excursion
1763       (save-restriction
1764         (widen)
1765         (if (and (file-readable-p filename)
1766                  (mail-file-babyl-p filename))
1767             (rmail-output-to-rmail-file filename t)
1768           (gnus-output-to-mail filename)))))
1769   filename)
1770
1771 (defun gnus-summary-save-in-file (&optional filename overwrite)
1772   "Append this article to file.
1773 Optional argument FILENAME specifies file name.
1774 Directory to save to is default to `gnus-article-save-directory'."
1775   (setq filename (gnus-read-save-file-name
1776                   "Save %s in file:" filename
1777                   gnus-file-save-name gnus-newsgroup-name
1778                   gnus-current-headers 'gnus-newsgroup-last-file))
1779   (gnus-eval-in-buffer-window gnus-save-article-buffer
1780     (save-excursion
1781       (save-restriction
1782         (widen)
1783         (when (and overwrite
1784                    (file-exists-p filename))
1785           (delete-file filename))
1786         (gnus-output-to-file filename))))
1787   filename)
1788
1789 (defun gnus-summary-write-to-file (&optional filename)
1790   "Write this article to a file.
1791 Optional argument FILENAME specifies file name.
1792 The directory to save in defaults to `gnus-article-save-directory'."
1793   (gnus-summary-save-in-file nil t))
1794
1795 (defun gnus-summary-save-body-in-file (&optional filename)
1796   "Append this article body to a file.
1797 Optional argument FILENAME specifies file name.
1798 The directory to save in defaults to `gnus-article-save-directory'."
1799   (setq filename (gnus-read-save-file-name
1800                   "Save %s body in file:" filename
1801                   gnus-file-save-name gnus-newsgroup-name
1802                   gnus-current-headers 'gnus-newsgroup-last-file))
1803   (gnus-eval-in-buffer-window gnus-save-article-buffer
1804     (save-excursion
1805       (save-restriction
1806         (widen)
1807         (when (article-goto-body)
1808           (narrow-to-region (point) (point-max)))
1809         (gnus-output-to-file filename))))
1810   filename)
1811
1812 (defun gnus-summary-save-in-pipe (&optional command)
1813   "Pipe this article to subprocess."
1814   (setq command
1815         (cond ((and (eq command 'default)
1816                     gnus-last-shell-command)
1817                gnus-last-shell-command)
1818               (command command)
1819               (t (read-string
1820                   (format
1821                    "Shell command on %s: "
1822                    (if (and gnus-number-of-articles-to-be-saved
1823                             (> gnus-number-of-articles-to-be-saved 1))
1824                        (format "these %d articles"
1825                                gnus-number-of-articles-to-be-saved)
1826                      "this article"))
1827                   gnus-last-shell-command))))
1828   (when (string-equal command "")
1829     (setq command gnus-last-shell-command))
1830   (gnus-eval-in-buffer-window gnus-article-buffer
1831     (save-restriction
1832       (widen)
1833       (shell-command-on-region (point-min) (point-max) command nil)))
1834   (setq gnus-last-shell-command command))
1835
1836 ;;; Article file names when saving.
1837
1838 (defun gnus-capitalize-newsgroup (newsgroup)
1839   "Capitalize NEWSGROUP name."
1840   (when (not (zerop (length newsgroup)))
1841     (concat (char-to-string (upcase (aref newsgroup 0)))
1842             (substring newsgroup 1))))
1843
1844 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
1845   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1846 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
1847 Otherwise, it is like ~/News/news/group/num."
1848   (let ((default
1849           (expand-file-name
1850            (concat (if (gnus-use-long-file-name 'not-save)
1851                        (gnus-capitalize-newsgroup newsgroup)
1852                      (gnus-newsgroup-directory-form newsgroup))
1853                    "/" (int-to-string (mail-header-number headers)))
1854            gnus-article-save-directory)))
1855     (if (and last-file
1856              (string-equal (file-name-directory default)
1857                            (file-name-directory last-file))
1858              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
1859         default
1860       (or last-file default))))
1861
1862 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
1863   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1864 If variable `gnus-use-long-file-name' is non-nil, it is
1865 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
1866   (let ((default
1867           (expand-file-name
1868            (concat (if (gnus-use-long-file-name 'not-save)
1869                        newsgroup
1870                      (gnus-newsgroup-directory-form newsgroup))
1871                    "/" (int-to-string (mail-header-number headers)))
1872            gnus-article-save-directory)))
1873     (if (and last-file
1874              (string-equal (file-name-directory default)
1875                            (file-name-directory last-file))
1876              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
1877         default
1878       (or last-file default))))
1879
1880 (defun gnus-Plain-save-name (newsgroup headers &optional last-file)
1881   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1882 If variable `gnus-use-long-file-name' is non-nil, it is
1883 ~/News/News.group.  Otherwise, it is like ~/News/news/group/news."
1884   (or last-file
1885       (expand-file-name
1886        (if (gnus-use-long-file-name 'not-save)
1887            (gnus-capitalize-newsgroup newsgroup)
1888          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
1889        gnus-article-save-directory)))
1890
1891 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
1892   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
1893 If variable `gnus-use-long-file-name' is non-nil, it is
1894 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
1895   (or last-file
1896       (expand-file-name
1897        (if (gnus-use-long-file-name 'not-save)
1898            newsgroup
1899          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
1900        gnus-article-save-directory)))
1901
1902 (eval-and-compile
1903   (mapcar
1904    (lambda (func)
1905      (let (afunc gfunc)
1906        (if (consp func)
1907            (setq afunc (car func)
1908                  gfunc (cdr func))
1909          (setq afunc func
1910                gfunc (intern (format "gnus-%s" func))))
1911        (fset gfunc
1912              (if (not (fboundp afunc))
1913                  nil
1914                `(lambda (&optional interactive &rest args)
1915                   ,(documentation afunc t)
1916                   (interactive (list t))
1917                   (save-excursion
1918                     (set-buffer gnus-article-buffer)
1919                     (if interactive
1920                         (call-interactively ',afunc)
1921                       (apply ',afunc args))))))))
1922    '(article-hide-headers
1923      article-hide-boring-headers
1924      article-treat-overstrike
1925      (article-fill . gnus-article-word-wrap)
1926      article-remove-cr
1927      article-display-x-face
1928      article-de-quoted-unreadable
1929      article-mime-decode-quoted-printable
1930      article-hide-pgp
1931      article-hide-pem
1932      article-hide-signature
1933      article-remove-trailing-blank-lines
1934      article-strip-leading-blank-lines
1935      article-strip-multiple-blank-lines
1936      article-strip-leading-space
1937      article-strip-trailing-space
1938      article-strip-blank-lines
1939      article-strip-all-blank-lines
1940      article-date-local
1941      article-date-iso8601
1942      article-date-original
1943      article-date-ut
1944      article-decode-mime-words
1945      article-decode-charset
1946      article-decode-encoded-words
1947      article-date-user
1948      article-date-lapsed
1949      article-emphasize
1950      article-treat-dumbquotes
1951      (article-show-all . gnus-article-show-all-headers))))
1952 \f
1953 ;;;
1954 ;;; Gnus article mode
1955 ;;;
1956
1957 (put 'gnus-article-mode 'mode-class 'special)
1958
1959 (set-keymap-parent gnus-article-mode-map widget-keymap)
1960
1961 (gnus-define-keys gnus-article-mode-map
1962   " " gnus-article-goto-next-page
1963   "\177" gnus-article-goto-prev-page
1964   [delete] gnus-article-goto-prev-page
1965   "\C-c^" gnus-article-refer-article
1966   "h" gnus-article-show-summary
1967   "s" gnus-article-show-summary
1968   "\C-c\C-m" gnus-article-mail
1969   "?" gnus-article-describe-briefly
1970   "e" gnus-article-edit
1971   "<" beginning-of-buffer
1972   ">" end-of-buffer
1973   "\C-c\C-i" gnus-info-find-node
1974   "\C-c\C-b" gnus-bug
1975
1976   "\C-d" gnus-article-read-summary-keys
1977   "\M-*" gnus-article-read-summary-keys
1978   "\M-#" gnus-article-read-summary-keys
1979   "\M-^" gnus-article-read-summary-keys
1980   "\M-g" gnus-article-read-summary-keys)
1981
1982 (substitute-key-definition
1983  'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
1984
1985 (defun gnus-article-make-menu-bar ()
1986   (gnus-turn-off-edit-menu 'article)
1987   (unless (boundp 'gnus-article-article-menu)
1988     (easy-menu-define
1989      gnus-article-article-menu gnus-article-mode-map ""
1990      '("Article"
1991        ["Scroll forwards" gnus-article-goto-next-page t]
1992        ["Scroll backwards" gnus-article-goto-prev-page t]
1993        ["Show summary" gnus-article-show-summary t]
1994        ["Fetch Message-ID at point" gnus-article-refer-article t]
1995        ["Mail to address at point" gnus-article-mail t]
1996        ["Send a bug report" gnus-bug t]))
1997
1998     (easy-menu-define
1999      gnus-article-treatment-menu gnus-article-mode-map ""
2000      '("Treatment"
2001        ["Hide headers" gnus-article-hide-headers t]
2002        ["Hide signature" gnus-article-hide-signature t]
2003        ["Hide citation" gnus-article-hide-citation t]
2004        ["Treat overstrike" gnus-article-treat-overstrike t]
2005        ["Remove carriage return" gnus-article-remove-cr t]
2006        ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
2007
2008     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
2009
2010     (when (boundp 'gnus-summary-post-menu)
2011       (define-key gnus-article-mode-map [menu-bar post]
2012         (cons "Post" gnus-summary-post-menu)))
2013
2014     (gnus-run-hooks 'gnus-article-menu-hook)))
2015
2016 (defun gnus-article-mode ()
2017   "Major mode for displaying an article.
2018
2019 All normal editing commands are switched off.
2020
2021 The following commands are available in addition to all summary mode
2022 commands:
2023 \\<gnus-article-mode-map>
2024 \\[gnus-article-next-page]\t Scroll the article one page forwards
2025 \\[gnus-article-prev-page]\t Scroll the article one page backwards
2026 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
2027 \\[gnus-article-show-summary]\t Display the summary buffer
2028 \\[gnus-article-mail]\t Send a reply to the address near point
2029 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
2030 \\[gnus-info-find-node]\t Go to the Gnus info node"
2031   (interactive)
2032   (when (gnus-visual-p 'article-menu 'menu)
2033     (gnus-article-make-menu-bar))
2034   (gnus-simplify-mode-line)
2035   (setq mode-name "Article")
2036   (setq major-mode 'gnus-article-mode)
2037   (make-local-variable 'minor-mode-alist)
2038   (use-local-map gnus-article-mode-map)
2039   (gnus-update-format-specifications nil 'article-mode)
2040   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
2041   (make-local-variable 'gnus-page-broken)
2042   (make-local-variable 'gnus-button-marker-list)
2043   (make-local-variable 'gnus-article-current-summary)
2044   (make-local-variable 'gnus-article-mime-handles)
2045   (make-local-variable 'gnus-article-decoded-p)
2046   (make-local-variable 'gnus-article-mime-handle-alist)
2047   (gnus-set-default-directory)
2048   (buffer-disable-undo)
2049   (setq buffer-read-only t)
2050   (set-syntax-table gnus-article-mode-syntax-table)
2051   (mm-enable-multibyte)
2052   (gnus-run-hooks 'gnus-article-mode-hook))
2053
2054 (defun gnus-article-setup-buffer ()
2055   "Initialize the article buffer."
2056   (let* ((name (if gnus-single-article-buffer "*Article*"
2057                  (concat "*Article " gnus-newsgroup-name "*")))
2058          (original
2059           (progn (string-match "\\*Article" name)
2060                  (concat " *Original Article"
2061                          (substring name (match-end 0))))))
2062     (setq gnus-article-buffer name)
2063     (setq gnus-original-article-buffer original)
2064     (setq gnus-article-mime-handle-alist nil)
2065     ;; This might be a variable local to the summary buffer.
2066     (unless gnus-single-article-buffer
2067       (save-excursion
2068         (set-buffer gnus-summary-buffer)
2069         (setq gnus-article-buffer name)
2070         (setq gnus-original-article-buffer original)
2071         (gnus-set-global-variables)))
2072     ;; Init original article buffer.
2073     (save-excursion
2074       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2075       (mm-enable-multibyte)
2076       (setq major-mode 'gnus-original-article-mode)
2077       (make-local-variable 'gnus-original-article))
2078     (if (get-buffer name)
2079         (save-excursion
2080           (set-buffer name)
2081           (buffer-disable-undo)
2082           (setq buffer-read-only t)
2083           (unless (eq major-mode 'gnus-article-mode)
2084             (gnus-article-mode))
2085           (current-buffer))
2086       (save-excursion
2087         (set-buffer (gnus-get-buffer-create name))
2088         (gnus-article-mode)
2089         (make-local-variable 'gnus-summary-buffer)
2090         (gnus-summary-set-local-parameters gnus-newsgroup-name)
2091         (current-buffer)))))
2092
2093 ;; Set article window start at LINE, where LINE is the number of lines
2094 ;; from the head of the article.
2095 (defun gnus-article-set-window-start (&optional line)
2096   (set-window-start
2097    (get-buffer-window gnus-article-buffer t)
2098    (save-excursion
2099      (set-buffer gnus-article-buffer)
2100      (goto-char (point-min))
2101      (if (not line)
2102          (point-min)
2103        (gnus-message 6 "Moved to bookmark")
2104        (search-forward "\n\n" nil t)
2105        (forward-line line)
2106        (point)))))
2107
2108 (defun gnus-article-prepare (article &optional all-headers header)
2109   "Prepare ARTICLE in article mode buffer.
2110 ARTICLE should either be an article number or a Message-ID.
2111 If ARTICLE is an id, HEADER should be the article headers.
2112 If ALL-HEADERS is non-nil, no headers are hidden."
2113   (save-excursion
2114     ;; Make sure we start in a summary buffer.
2115     (unless (eq major-mode 'gnus-summary-mode)
2116       (set-buffer gnus-summary-buffer))
2117     (setq gnus-summary-buffer (current-buffer))
2118     (let* ((gnus-article (if header (mail-header-number header) article))
2119            (summary-buffer (current-buffer))
2120            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
2121            (group gnus-newsgroup-name)
2122            result)
2123       (save-excursion
2124         (gnus-article-setup-buffer)
2125         (set-buffer gnus-article-buffer)
2126         ;; Deactivate active regions.
2127         (when (and (boundp 'transient-mark-mode)
2128                    transient-mark-mode)
2129           (setq mark-active nil))
2130         (if (not (setq result (let ((buffer-read-only nil))
2131                                 (gnus-request-article-this-buffer
2132                                  article group))))
2133             ;; There is no such article.
2134             (save-excursion
2135               (when (and (numberp article)
2136                          (not (memq article gnus-newsgroup-sparse)))
2137                 (setq gnus-article-current
2138                       (cons gnus-newsgroup-name article))
2139                 (set-buffer gnus-summary-buffer)
2140                 (setq gnus-current-article article)
2141                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
2142                     (progn
2143                       (gnus-summary-set-agent-mark article)
2144                       (message "Message marked for downloading"))
2145                   (gnus-summary-mark-article article gnus-canceled-mark)
2146                   (unless (memq article gnus-newsgroup-sparse)
2147                     (gnus-error 1
2148                      "No such article (may have expired or been canceled)")))))
2149           (if (or (eq result 'pseudo)
2150                   (eq result 'nneething))
2151               (progn
2152                 (save-excursion
2153                   (set-buffer summary-buffer)
2154                   (push article gnus-newsgroup-history)
2155                   (setq gnus-last-article gnus-current-article
2156                         gnus-current-article 0
2157                         gnus-current-headers nil
2158                         gnus-article-current nil)
2159                   (if (eq result 'nneething)
2160                       (gnus-configure-windows 'summary)
2161                     (gnus-configure-windows 'article))
2162                   (gnus-set-global-variables))
2163                 (let ((gnus-article-mime-handle-alist-1
2164                        gnus-article-mime-handle-alist))
2165                   (gnus-set-mode-line 'article)))
2166             ;; The result from the `request' was an actual article -
2167             ;; or at least some text that is now displayed in the
2168             ;; article buffer.
2169             (when (and (numberp article)
2170                        (not (eq article gnus-current-article)))
2171               ;; Seems like a new article has been selected.
2172               ;; `gnus-current-article' must be an article number.
2173               (save-excursion
2174                 (set-buffer summary-buffer)
2175                 (push article gnus-newsgroup-history)
2176                 (setq gnus-last-article gnus-current-article
2177                       gnus-current-article article
2178                       gnus-current-headers
2179                       (gnus-summary-article-header gnus-current-article)
2180                       gnus-article-current
2181                       (cons gnus-newsgroup-name gnus-current-article))
2182                 (unless (vectorp gnus-current-headers)
2183                   (setq gnus-current-headers nil))
2184                 (gnus-summary-goto-subject gnus-current-article)
2185                 (when (gnus-summary-show-thread)
2186                   ;; If the summary buffer really was folded, the
2187                   ;; previous goto may not actually have gone to
2188                   ;; the right article, but the thread root instead.
2189                   ;; So we go again.
2190                   (gnus-summary-goto-subject gnus-current-article))
2191                 (gnus-run-hooks 'gnus-mark-article-hook)
2192                 (gnus-set-mode-line 'summary)
2193                 (when (gnus-visual-p 'article-highlight 'highlight)
2194                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
2195                 ;; Set the global newsgroup variables here.
2196                 ;; Suggested by Jim Sisolak
2197                 ;; <sisolak@trans4.neep.wisc.edu>.
2198                 (gnus-set-global-variables)
2199                 (setq gnus-have-all-headers
2200                       (or all-headers gnus-show-all-headers))))
2201             (when (or (numberp article)
2202                       (stringp article))
2203               (gnus-article-prepare-display)
2204               ;; Do page break.
2205               (goto-char (point-min))
2206               (setq gnus-page-broken
2207                     (when gnus-break-pages
2208                       (gnus-narrow-to-page)
2209                       t)))
2210             (let ((gnus-article-mime-handle-alist-1
2211                    gnus-article-mime-handle-alist))
2212               (gnus-set-mode-line 'article))
2213             (gnus-configure-windows 'article)
2214             (article-goto-body)
2215             (set-window-point (get-buffer-window (current-buffer)) (point))
2216             t))))))
2217
2218 (defun gnus-article-prepare-display ()
2219   "Make the current buffer look like a nice article."
2220   ;; Hooks for getting information from the article.
2221   ;; This hook must be called before being narrowed.
2222   (let ((gnus-article-buffer (current-buffer))
2223         buffer-read-only)
2224     (unless (eq major-mode 'gnus-article-mode)
2225       (gnus-article-mode))
2226     (setq buffer-read-only nil)
2227     (gnus-run-hooks 'gnus-tmp-internal-hook)
2228     (gnus-run-hooks 'gnus-article-prepare-hook)
2229     (when gnus-display-mime-function
2230       ;(let ((url-standalone-mode (not gnus-plugged)))
2231         (funcall gnus-display-mime-function)
2232         )
2233     ;)
2234     ;; Perform the article display hooks.
2235     (gnus-run-hooks 'gnus-article-display-hook)))
2236
2237 ;;;
2238 ;;; Gnus MIME viewing functions
2239 ;;;
2240
2241 (defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}%e\n"
2242   "The following specs can be used:
2243 %t  The MIME type
2244 %n  The `name' parameter
2245 %d  The description, if any
2246 %l  The length of the encoded part
2247 %p  The part identifier
2248 %e  Dots if the part isn't displayed")
2249
2250 (defvar gnus-mime-button-line-format-alist
2251   '((?t gnus-tmp-type ?s)
2252     (?n gnus-tmp-name ?s)
2253     (?d gnus-tmp-description ?s)
2254     (?p gnus-tmp-id ?s)
2255     (?l gnus-tmp-length ?d)
2256     (?e gnus-tmp-dots ?s)))
2257
2258 (defvar gnus-mime-button-commands
2259   '((gnus-article-press-button  "\r"    "Toggle Display")
2260     ;(gnus-mime-view-part       "\M-\r" "View Interactively...")
2261     (gnus-mime-view-part        "v"     "View Interactively...")
2262     (gnus-mime-save-part        "o"     "Save...")
2263     (gnus-mime-copy-part        "c"     "View In Buffer")
2264     (gnus-mime-inline-part      "i"     "View Inline")
2265     (gnus-mime-externalize-part "e"     "View Externally")
2266     (gnus-mime-pipe-part        "|"     "Pipe To Command...")))
2267
2268 (defun gnus-article-mime-part-status ()
2269   (if gnus-article-mime-handle-alist-1
2270       (format " (%d parts)" (length gnus-article-mime-handle-alist-1))
2271     ""))
2272
2273 (defvar gnus-mime-button-map nil)
2274 (unless gnus-mime-button-map
2275   (setq gnus-mime-button-map (make-sparse-keymap))
2276   (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
2277   (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
2278   (define-key gnus-mime-button-map gnus-mouse-3 'gnus-mime-button-menu)
2279   (mapcar (lambda (c)
2280             (define-key gnus-mime-button-map (cadr c) (car c)))
2281           gnus-mime-button-commands))
2282
2283 (defun gnus-mime-button-menu (event)
2284   "Construct a context-sensitive menu of MIME commands."
2285   (interactive "e")
2286   (gnus-article-check-buffer)
2287   (let ((response (x-popup-menu
2288                   t `("MIME Part"
2289                       ("" ,@(mapcar (lambda (c)
2290                                       (cons (caddr c) (car c)))
2291                                     gnus-mime-button-commands)))))
2292         (pos (event-start event)))
2293     (when response
2294       (set-buffer (window-buffer (posn-window pos)))
2295       (goto-char (posn-point pos))
2296       (funcall response))))
2297
2298 (defun gnus-mime-view-all-parts ()
2299   "View all the MIME parts."
2300   (interactive)
2301   (save-current-buffer
2302     (set-buffer gnus-article-buffer)
2303     (let ((handles gnus-article-mime-handles)
2304           (rfc2047-default-charset gnus-newsgroup-default-charset)
2305           (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
2306       (while handles
2307         (mm-display-part (pop handles))))))
2308
2309 (defun gnus-mime-save-part ()
2310   "Save the MIME part under point."
2311   (interactive)
2312   (gnus-article-check-buffer)
2313   (let ((data (get-text-property (point) 'gnus-data)))
2314     (mm-save-part data)))
2315
2316 (defun gnus-mime-pipe-part ()
2317   "Pipe the MIME part under point to a process."
2318   (interactive)
2319   (gnus-article-check-buffer)
2320   (let ((data (get-text-property (point) 'gnus-data)))
2321     (mm-pipe-part data)))
2322
2323 (defun gnus-mime-view-part ()
2324   "Interactively choose a view method for the MIME part under point."
2325   (interactive)
2326   (gnus-article-check-buffer)
2327   (let ((data (get-text-property (point) 'gnus-data))
2328         ;(url-standalone-mode (not gnus-plugged))
2329         )
2330     (mm-interactively-view-part data)))
2331
2332 (defun gnus-mime-copy-part (&optional handle)
2333   "Put the the MIME part under point into a new buffer."
2334   (interactive)
2335   (gnus-article-check-buffer)
2336   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2337          (contents (mm-get-part handle))
2338          (buffer (generate-new-buffer
2339                        (file-name-nondirectory
2340                         (or
2341                          (mail-content-type-get (mm-handle-type handle) 'name)
2342                          (mail-content-type-get (mm-handle-type handle)
2343                                                 'filename)
2344                          "*decoded*")))))
2345     (switch-to-buffer buffer)
2346     (insert contents)
2347     (normal-mode)
2348     (goto-char (point-min))))
2349
2350 (defun gnus-mime-inline-part (&optional charset)
2351   "Insert the MIME part under point into the current buffer."
2352   (interactive "P") ; For compatibility reasons we are not using "z".
2353   (gnus-article-check-buffer)
2354   (let* ((data (get-text-property (point) 'gnus-data))
2355          (contents (mm-get-part data))
2356          ;(url-standalone-mode (not gnus-plugged))
2357          (b (point))
2358          buffer-read-only)
2359     (if (mm-handle-undisplayer data)
2360         (mm-remove-part data)
2361       (forward-line 2)
2362       (when charset
2363         (unless (symbolp charset)
2364           (setq charset (mm-read-coding-system "Charset: ")))
2365         (setq contents (mm-decode-coding-string contents charset)))
2366       (mm-insert-inline data contents)
2367       (goto-char b))))
2368
2369 (defun gnus-mime-externalize-part (&optional handle)
2370   "Insert the MIME part under point into the current buffer."
2371   (interactive)
2372   (gnus-article-check-buffer)
2373   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
2374          ;(url-standalone-mode (not gnus-plugged))
2375          (mm-user-display-methods nil)
2376          (rfc2047-default-charset gnus-newsgroup-default-charset)
2377          (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
2378     (if (mm-handle-undisplayer handle)
2379         (mm-remove-part handle)
2380       (mm-display-part handle))))
2381
2382 (defun gnus-article-part-wrapper (n function)
2383   (save-current-buffer
2384     (set-buffer gnus-article-buffer)
2385     (when (> n (length gnus-article-mime-handle-alist))
2386       (error "No such part"))
2387     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
2388       (funcall function handle))))
2389
2390 (defun gnus-article-pipe-part (n)
2391   "Pipe MIME part N, which is the numerical prefix."
2392   (interactive "p")
2393   (gnus-article-part-wrapper n 'mm-pipe-part))
2394
2395 (defun gnus-article-save-part (n)
2396   "Save MIME part N, which is the numerical prefix."
2397   (interactive "p")
2398   (gnus-article-part-wrapper n 'mm-save-part))
2399
2400 (defun gnus-article-interactively-view-part (n)
2401   "Pipe MIME part N, which is the numerical prefix."
2402   (interactive "p")
2403   (gnus-article-part-wrapper n 'mm-interactively-view-part))
2404
2405 (defun gnus-article-copy-part (n)
2406   "Pipe MIME part N, which is the numerical prefix."
2407   (interactive "p")
2408   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
2409
2410 (defun gnus-article-externalize-part (n)
2411   "Pipe MIME part N, which is the numerical prefix."
2412   (interactive "p")
2413   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
2414
2415 (defun gnus-article-view-part (n)
2416   "View MIME part N, which is the numerical prefix."
2417   (interactive "p")
2418   (save-current-buffer
2419     (set-buffer gnus-article-buffer)
2420     (when (> n (length gnus-article-mime-handle-alist))
2421       (error "No such part"))
2422     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
2423       (when (gnus-article-goto-part n)
2424         (if (equal (car handle) "multipart/alternative")
2425             (gnus-article-press-button)
2426           (when (eq (gnus-mm-display-part handle) 'internal)
2427             (gnus-set-window-start)))))))
2428
2429 (defun gnus-mm-display-part (handle)
2430   "Display HANDLE and fix MIME button."
2431   (let ((id (get-text-property (point) 'gnus-part))
2432         (point (point))
2433         buffer-read-only)
2434     (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
2435     (gnus-insert-mime-button
2436      handle id (list (not (mm-handle-displayed-p handle))))
2437     (prog1
2438         (let ((window (selected-window))
2439               (rfc2047-default-charset gnus-newsgroup-default-charset)
2440               (mm-charset-iso-8859-1-forced gnus-newsgroup-iso-8859-1-forced))
2441           (save-excursion
2442             (unwind-protect
2443                 (let ((win (get-buffer-window (current-buffer) t)))
2444                   (if win
2445                       (select-window win))
2446                   (goto-char point)
2447                   (forward-line)
2448                   (mm-display-part handle))
2449               (select-window window))))
2450       (goto-char point))))
2451
2452 (defun gnus-article-goto-part (n)
2453   "Go to MIME part N."
2454   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
2455     (when point
2456       (goto-char point))))
2457
2458 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
2459   (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name))
2460         (gnus-tmp-type (car (mm-handle-type handle)))
2461         (gnus-tmp-description (mm-handle-description handle))
2462         (gnus-tmp-dots
2463          (if (if displayed (car displayed)
2464                (mm-handle-displayed-p handle))
2465              "" "..."))
2466         (gnus-tmp-length (save-excursion
2467                            (set-buffer (mm-handle-buffer handle))
2468                            (buffer-size)))
2469         b e)
2470     (setq gnus-tmp-name
2471           (if gnus-tmp-name
2472               (concat " (" gnus-tmp-name ")")
2473             ""))
2474     (setq gnus-tmp-description
2475           (if gnus-tmp-description
2476               (concat " (" gnus-tmp-description ")")
2477             ""))
2478     (unless (bolp)
2479       (insert "\n"))
2480     (setq b (point))
2481     (gnus-eval-format
2482      gnus-mime-button-line-format gnus-mime-button-line-format-alist
2483      `(local-map ,gnus-mime-button-map
2484                  keymap ,gnus-mime-button-map
2485                  gnus-callback gnus-mm-display-part
2486                  gnus-part ,gnus-tmp-id
2487                  article-type annotation
2488                  gnus-data ,handle))
2489     (setq e (point))
2490     (widget-convert-button 'link b e :action 'gnus-widget-press-button
2491                            :button-keymap gnus-mime-button-map)))
2492
2493 (defun gnus-widget-press-button (elems el)
2494   (goto-char (widget-get elems :from))
2495   (let ((url-standalone-mode (not gnus-plugged)))
2496     (gnus-article-press-button)))
2497
2498 (defun gnus-display-mime (&optional ihandles)
2499   "Insert MIME buttons in the buffer."
2500   (save-selected-window
2501     (let ((window (get-buffer-window gnus-article-buffer)))
2502       (when window
2503         (select-window window)))
2504     (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
2505            handle name type b e display)
2506       (unless ihandles
2507         ;; Top-level call; we clean up.
2508         (mm-destroy-parts gnus-article-mime-handles)
2509         (setq gnus-article-mime-handles handles
2510               gnus-article-mime-handle-alist nil)
2511         ;; We allow users to glean info from the handles.
2512         (when gnus-article-mime-part-function
2513           (gnus-mime-part-function handles)))
2514       (when (and handles
2515                  (or (not (stringp (car handles)))
2516                      (cdr handles)))
2517         (unless ihandles
2518           ;; Clean up for mime parts.
2519           (article-goto-body)
2520           (delete-region (point) (point-max)))
2521         (if (stringp (car handles))
2522             (if (equal (car handles) "multipart/alternative")
2523                 (let ((id (1+ (length gnus-article-mime-handle-alist))))
2524                   (push (cons id handles) gnus-article-mime-handle-alist)
2525                   (gnus-mime-display-alternative (cdr handles) nil nil id))
2526               (gnus-mime-display-mixed (cdr handles)))
2527           (gnus-mime-display-single handles))))))
2528
2529 (defun gnus-mime-part-function (handles)
2530   (if (stringp (car handles))
2531       (mapcar 'gnus-mime-part-function (cdr handles))
2532     (funcall gnus-article-mime-part-function handles)))
2533
2534 (defun gnus-mime-display-mixed (handles)
2535   (let (handle)
2536     (while (setq handle (pop handles))
2537       (if (stringp (car handle))
2538           (if (equal (car handle) "multipart/alternative")
2539               (let ((id (1+ (length gnus-article-mime-handle-alist))))
2540                 (push (cons id handle) gnus-article-mime-handle-alist)
2541                 (gnus-mime-display-alternative (cdr handle) nil nil id))
2542             (gnus-mime-display-mixed (cdr handle)))
2543         (gnus-mime-display-single handle)))))
2544
2545 (defun gnus-mime-display-single (handle)
2546   (let ((type (car (mm-handle-type handle)))
2547         (ignored gnus-ignored-mime-types)
2548         (not-attachment t)
2549         display text)
2550     (catch 'ignored
2551       (progn
2552         (while ignored
2553           (when (string-match (pop ignored) type)
2554             (throw 'ignored nil)))
2555         (if (and (mm-automatic-display-p type)
2556                  (mm-inlinable-part-p type)
2557                  (setq not-attachment
2558                        (or (not (mm-handle-disposition handle))
2559                            (equal (car (mm-handle-disposition handle))
2560                                   "inline"))))
2561             (setq display t)
2562           (when (equal (car (split-string type "/"))
2563                        "text")
2564             (setq text t)))
2565         (let ((id (1+ (length gnus-article-mime-handle-alist))))
2566           (push (cons id handle) gnus-article-mime-handle-alist)
2567           (when (or (not display)
2568                     (not (gnus-unbuttonized-mime-type-p type)))
2569             (gnus-article-insert-newline)
2570             (gnus-insert-mime-button
2571              handle id (list (or display
2572                                  (and (not not-attachment) text))))
2573             (gnus-article-insert-newline)))
2574         (gnus-article-insert-newline)
2575         (cond
2576          (display
2577           (forward-line -2)
2578           (let ((rfc2047-default-charset gnus-newsgroup-default-charset)
2579                 (mm-charset-iso-8859-1-forced
2580                  gnus-newsgroup-iso-8859-1-forced))
2581             (mm-display-part handle t))
2582           (goto-char (point-max)))
2583          ((and text not-attachment)
2584           (forward-line -2)
2585           (gnus-article-insert-newline)
2586           (mm-insert-inline handle (mm-get-part handle))
2587           (goto-char (point-max))))))))
2588
2589 (defun gnus-unbuttonized-mime-type-p (type)
2590   "Say whether TYPE is to be unbuttonized."
2591   (unless gnus-inhibit-mime-unbuttonizing
2592     (catch 'found
2593       (let ((types gnus-unbuttonized-mime-types))
2594         (while types
2595           (when (string-match (pop types) type)
2596             (throw 'found t)))))))
2597
2598 (defun gnus-article-insert-newline ()
2599   "Insert a newline, but mark it as undeletable."
2600   (gnus-put-text-property
2601    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
2602
2603 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
2604   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
2605          (ihandles handles)
2606          (point (point))
2607          handle buffer-read-only from props begend not-pref)
2608     (save-window-excursion
2609       (save-restriction
2610         (when ibegend
2611           (narrow-to-region (car ibegend)
2612                             (or (cdr ibegend)
2613                                 (progn
2614                                   (goto-char (car ibegend))
2615                                   (forward-line 2)
2616                                   (point))))
2617           (delete-region (point-min) (point-max))
2618           (mm-remove-parts handles))
2619         (setq begend (list (point-marker)))
2620         ;; Do the toggle.
2621         (unless (setq not-pref (cadr (member preferred ihandles)))
2622           (setq not-pref (car ihandles)))
2623         (when (or ibegend
2624                   (not (gnus-unbuttonized-mime-type-p
2625                         "multipart/alternative")))
2626           (gnus-add-text-properties
2627            (setq from (point))
2628            (progn
2629              (insert (format "%d.  " id))
2630              (point))
2631            `(gnus-callback
2632              (lambda (handles)
2633                (unless ,(not ibegend)
2634                  (setq gnus-article-mime-handle-alist
2635                        ',gnus-article-mime-handle-alist))
2636                (gnus-mime-display-alternative
2637                 ',ihandles ',not-pref ',begend ,id))
2638              local-map ,gnus-mime-button-map
2639              ,gnus-mouse-face-prop ,gnus-article-mouse-face
2640              face ,gnus-article-button-face
2641              keymap ,gnus-mime-button-map
2642              gnus-part ,id
2643              gnus-data ,handle))
2644           (widget-convert-button 'link from (point)
2645                                  :action 'gnus-widget-press-button
2646                                  :button-keymap gnus-widget-button-keymap)
2647           ;; Do the handles
2648           (while (setq handle (pop handles))
2649             (gnus-add-text-properties
2650              (setq from (point))
2651              (progn
2652                (insert (format "[%c] %-18s"
2653                                (if (equal handle preferred) ?* ? )
2654                                (if (stringp (car handle))
2655                                    (car handle)
2656                                  (car (mm-handle-type handle)))))
2657                (point))
2658              `(gnus-callback
2659                (lambda (handles)
2660                  (unless ,(not ibegend)
2661                    (setq gnus-article-mime-handle-alist
2662                          ',gnus-article-mime-handle-alist))
2663                  (gnus-mime-display-alternative
2664                   ',ihandles ',handle ',begend ,id))
2665                local-map ,gnus-mime-button-map
2666                ,gnus-mouse-face-prop ,gnus-article-mouse-face
2667                face ,gnus-article-button-face
2668                keymap ,gnus-mime-button-map
2669                gnus-part ,id
2670                gnus-data ,handle))
2671             (widget-convert-button 'link from (point)
2672                                    :action 'gnus-widget-press-button
2673                                    :button-keymap gnus-widget-button-keymap)
2674             (insert "  "))
2675           (insert "\n\n"))
2676         (when preferred
2677           (if (stringp (car preferred))
2678               (gnus-display-mime preferred)
2679             (let ((rfc2047-default-charset gnus-newsgroup-default-charset)
2680                   (mm-charset-iso-8859-1-forced
2681                    gnus-newsgroup-iso-8859-1-forced))
2682               (mm-display-part preferred)))
2683           (goto-char (point-max))
2684           (setcdr begend (point-marker)))))
2685     (when ibegend
2686       (goto-char point))))
2687
2688 (defun gnus-article-wash-status ()
2689   "Return a string which display status of article washing."
2690   (save-excursion
2691     (set-buffer gnus-article-buffer)
2692     (let ((cite (gnus-article-hidden-text-p 'cite))
2693           (headers (gnus-article-hidden-text-p 'headers))
2694           (boring (gnus-article-hidden-text-p 'boring-headers))
2695           (pgp (gnus-article-hidden-text-p 'pgp))
2696           (pem (gnus-article-hidden-text-p 'pem))
2697           (signature (gnus-article-hidden-text-p 'signature))
2698           (overstrike (gnus-article-hidden-text-p 'overstrike))
2699           (emphasis (gnus-article-hidden-text-p 'emphasis)))
2700       (format "%c%c%c%c%c%c"
2701               (if cite ?c ? )
2702               (if (or headers boring) ?h ? )
2703               (if (or pgp pem) ?p ? )
2704               (if signature ?s ? )
2705               (if overstrike ?o ? )
2706               (if emphasis ?e ? )))))
2707
2708 (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
2709
2710 (defun gnus-article-maybe-hide-headers ()
2711   "Hide unwanted headers if `gnus-have-all-headers' is nil.
2712 Provided for backwards compatibility."
2713   (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
2714       gnus-inhibit-hiding
2715       (gnus-article-hide-headers)))
2716
2717 ;;; Article savers.
2718
2719 (defun gnus-output-to-file (file-name)
2720   "Append the current article to a file named FILE-NAME."
2721   (let ((artbuf (current-buffer)))
2722     (with-temp-buffer
2723       (insert-buffer-substring artbuf)
2724       ;; Append newline at end of the buffer as separator, and then
2725       ;; save it to file.
2726       (goto-char (point-max))
2727       (insert "\n")
2728       (append-to-file (point-min) (point-max) file-name)
2729       t)))
2730
2731 (defun gnus-narrow-to-page (&optional arg)
2732   "Narrow the article buffer to a page.
2733 If given a numerical ARG, move forward ARG pages."
2734   (interactive "P")
2735   (setq arg (if arg (prefix-numeric-value arg) 0))
2736   (save-excursion
2737     (set-buffer gnus-article-buffer)
2738     (goto-char (point-min))
2739     (widen)
2740     ;; Remove any old next/prev buttons.
2741     (when (gnus-visual-p 'page-marker)
2742       (let ((buffer-read-only nil))
2743         (gnus-remove-text-with-property 'gnus-prev)
2744         (gnus-remove-text-with-property 'gnus-next)))
2745     (when
2746         (cond ((< arg 0)
2747                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
2748               ((> arg 0)
2749                (re-search-forward page-delimiter nil 'move arg)))
2750       (goto-char (match-end 0)))
2751     (narrow-to-region
2752      (point)
2753      (if (re-search-forward page-delimiter nil 'move)
2754          (match-beginning 0)
2755        (point)))
2756     (when (and (gnus-visual-p 'page-marker)
2757                (not (= (point-min) 1)))
2758       (save-excursion
2759         (goto-char (point-min))
2760         (gnus-insert-prev-page-button)))
2761     (when (and (gnus-visual-p 'page-marker)
2762                (< (+ (point-max) 2) (buffer-size)))
2763       (save-excursion
2764         (goto-char (point-max))
2765         (gnus-insert-next-page-button)))))
2766
2767 ;; Article mode commands
2768
2769 (defun gnus-article-goto-next-page ()
2770   "Show the next page of the article."
2771   (interactive)
2772   (when (gnus-article-next-page)
2773     (goto-char (point-min))
2774     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
2775
2776 (defun gnus-article-goto-prev-page ()
2777   "Show the next page of the article."
2778   (interactive)
2779   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
2780     (gnus-article-prev-page nil)))
2781
2782 (defun gnus-article-next-page (&optional lines)
2783   "Show the next page of the current article.
2784 If end of article, return non-nil.  Otherwise return nil.
2785 Argument LINES specifies lines to be scrolled up."
2786   (interactive "p")
2787   (move-to-window-line -1)
2788   (if (save-excursion
2789         (end-of-line)
2790         (and (pos-visible-in-window-p)  ;Not continuation line.
2791              (eobp)))
2792       ;; Nothing in this page.
2793       (if (or (not gnus-page-broken)
2794               (save-excursion
2795                 (save-restriction
2796                   (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
2797           t                             ;Nothing more.
2798         (gnus-narrow-to-page 1)         ;Go to next page.
2799         nil)
2800     ;; More in this page.
2801     (let ((scroll-in-place nil))
2802       (condition-case ()
2803           (scroll-up lines)
2804         (end-of-buffer
2805          ;; Long lines may cause an end-of-buffer error.
2806          (goto-char (point-max)))))
2807     (move-to-window-line 0)
2808     nil))
2809
2810 (defun gnus-article-prev-page (&optional lines)
2811   "Show previous page of current article.
2812 Argument LINES specifies lines to be scrolled down."
2813   (interactive "p")
2814   (move-to-window-line 0)
2815   (if (and gnus-page-broken
2816            (bobp)
2817            (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
2818       (progn
2819         (gnus-narrow-to-page -1)        ;Go to previous page.
2820         (goto-char (point-max))
2821         (recenter -1))
2822     (let ((scroll-in-place nil))
2823       (prog1
2824           (condition-case ()
2825               (scroll-down lines)
2826             (beginning-of-buffer
2827              (goto-char (point-min))))
2828         (move-to-window-line 0)))))
2829
2830 (defun gnus-article-refer-article ()
2831   "Read article specified by message-id around point."
2832   (interactive)
2833   (let ((point (point)))
2834     (search-forward ">" nil t)          ;Move point to end of "<....>".
2835     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
2836         (let ((message-id (match-string 1)))
2837           (goto-char point)
2838           (set-buffer gnus-summary-buffer)
2839           (gnus-summary-refer-article message-id))
2840       (goto-char (point))
2841       (error "No references around point"))))
2842
2843 (defun gnus-article-show-summary ()
2844   "Reconfigure windows to show summary buffer."
2845   (interactive)
2846   (if (not (gnus-buffer-live-p gnus-summary-buffer))
2847       (error "There is no summary buffer for this article buffer")
2848     (gnus-article-set-globals)
2849     (gnus-configure-windows 'article)
2850     (gnus-summary-goto-subject gnus-current-article)
2851     (gnus-summary-position-point)))
2852
2853 (defun gnus-article-describe-briefly ()
2854   "Describe article mode commands briefly."
2855   (interactive)
2856   (gnus-message 6
2857                 (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")))
2858
2859 (defun gnus-article-summary-command ()
2860   "Execute the last keystroke in the summary buffer."
2861   (interactive)
2862   (let ((obuf (current-buffer))
2863         (owin (current-window-configuration))
2864         func)
2865     (switch-to-buffer gnus-article-current-summary 'norecord)
2866     (setq func (lookup-key (current-local-map) (this-command-keys)))
2867     (call-interactively func)
2868     (set-buffer obuf)
2869     (set-window-configuration owin)
2870     (set-window-point (get-buffer-window (current-buffer)) (point))))
2871
2872 (defun gnus-article-summary-command-nosave ()
2873   "Execute the last keystroke in the summary buffer."
2874   (interactive)
2875   (let (func)
2876     (pop-to-buffer gnus-article-current-summary 'norecord)
2877     (setq func (lookup-key (current-local-map) (this-command-keys)))
2878     (call-interactively func)))
2879
2880 (defun gnus-article-check-buffer ()
2881   "Beep if not in an article buffer."
2882   (unless (equal major-mode 'gnus-article-mode)
2883     (error "Command invoked outside of a Gnus article buffer")))
2884
2885 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
2886   "Read a summary buffer key sequence and execute it from the article buffer."
2887   (interactive "P")
2888   (gnus-article-check-buffer)
2889   (let ((nosaves
2890          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
2891            "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
2892            "=" "^" "\M-^" "|"))
2893         (nosave-but-article
2894          '("A\r"))
2895         (nosave-in-article
2896          '("\C-d"))
2897         (up-to-top
2898          '("n" "Gn" "p" "Gp"))
2899         keys new-sum-point)
2900     (save-excursion
2901       (set-buffer gnus-article-current-summary)
2902       (let (gnus-pick-mode)
2903         (push (or key last-command-event) unread-command-events)
2904         (setq keys (read-key-sequence nil))))
2905     (message "")
2906
2907     (if (or (member keys nosaves)
2908             (member keys nosave-but-article)
2909             (member keys nosave-in-article))
2910         (let (func)
2911           (save-window-excursion
2912             (pop-to-buffer gnus-article-current-summary 'norecord)
2913             ;; We disable the pick minor mode commands.
2914             (let (gnus-pick-mode)
2915               (setq func (lookup-key (current-local-map) keys))))
2916           (if (not func)
2917               (ding)
2918             (unless (member keys nosave-in-article)
2919               (set-buffer gnus-article-current-summary))
2920             (call-interactively func)
2921             (setq new-sum-point (point)))
2922           (when (member keys nosave-but-article)
2923             (pop-to-buffer gnus-article-buffer 'norecord)))
2924       ;; These commands should restore window configuration.
2925       (let ((obuf (current-buffer))
2926             (owin (current-window-configuration))
2927             (opoint (point))
2928             (summary gnus-article-current-summary)
2929             func in-buffer selected)
2930         (if not-restore-window
2931             (pop-to-buffer summary 'norecord)
2932           (switch-to-buffer summary 'norecord))
2933         (setq in-buffer (current-buffer))
2934         ;; We disable the pick minor mode commands.
2935         (if (setq func (let (gnus-pick-mode)
2936                          (lookup-key (current-local-map) keys)))
2937             (progn
2938               (call-interactively func)
2939               (setq new-sum-point (point)))
2940           (ding))
2941         (when (eq in-buffer (current-buffer))
2942           (setq selected (gnus-summary-select-article))
2943           (set-buffer obuf)
2944           (unless not-restore-window
2945             (set-window-configuration owin))
2946           (unless (or (not (eq selected 'old)) (member keys up-to-top))
2947             (set-window-point (get-buffer-window (current-buffer))
2948                               opoint))
2949           (let ((win (get-buffer-window gnus-article-current-summary)))
2950             (when win
2951               (set-window-point win new-sum-point))))))))
2952
2953 (defun gnus-article-hide (&optional arg force)
2954   "Hide all the gruft in the current article.
2955 This means that PGP stuff, signatures, cited text and (some)
2956 headers will be hidden.
2957 If given a prefix, show the hidden text instead."
2958   (interactive (append (gnus-article-hidden-arg) (list 'force)))
2959   (gnus-article-hide-headers arg)
2960   (gnus-article-hide-pgp arg)
2961   (gnus-article-hide-citation-maybe arg force)
2962   (gnus-article-hide-signature arg))
2963
2964 (defun gnus-article-maybe-highlight ()
2965   "Do some article highlighting if article highlighting is requested."
2966   (when (gnus-visual-p 'article-highlight 'highlight)
2967     (gnus-article-highlight-some)))
2968
2969 (defun gnus-check-group-server ()
2970   ;; Make sure the connection to the server is alive.
2971   (unless (gnus-server-opened
2972            (gnus-find-method-for-group gnus-newsgroup-name))
2973     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
2974     (gnus-request-group gnus-newsgroup-name t)))
2975
2976 (defun gnus-request-article-this-buffer (article group)
2977   "Get an article and insert it into this buffer."
2978   (let (do-update-line sparse-header)
2979     (prog1
2980         (save-excursion
2981           (erase-buffer)
2982           (gnus-kill-all-overlays)
2983           (setq group (or group gnus-newsgroup-name))
2984
2985           ;; Using `gnus-request-article' directly will insert the article into
2986           ;; `nntp-server-buffer' - so we'll save some time by not having to
2987           ;; copy it from the server buffer into the article buffer.
2988
2989           ;; We only request an article by message-id when we do not have the
2990           ;; headers for it, so we'll have to get those.
2991           (when (stringp article)
2992             (let ((gnus-override-method gnus-refer-article-method))
2993               (gnus-read-header article)))
2994
2995           ;; If the article number is negative, that means that this article
2996           ;; doesn't belong in this newsgroup (possibly), so we find its
2997           ;; message-id and request it by id instead of number.
2998           (when (and (numberp article)
2999                      gnus-summary-buffer
3000                      (get-buffer gnus-summary-buffer)
3001                      (gnus-buffer-exists-p gnus-summary-buffer))
3002             (save-excursion
3003               (set-buffer gnus-summary-buffer)
3004               (let ((header (gnus-summary-article-header article)))
3005                 (when (< article 0)
3006                   (cond
3007                    ((memq article gnus-newsgroup-sparse)
3008                     ;; This is a sparse gap article.
3009                     (setq do-update-line article)
3010                     (setq article (mail-header-id header))
3011                     (let ((gnus-override-method gnus-refer-article-method))
3012                       (setq sparse-header (gnus-read-header article)))
3013                     (setq gnus-newsgroup-sparse
3014                           (delq article gnus-newsgroup-sparse)))
3015                    ((vectorp header)
3016                     ;; It's a real article.
3017                     (setq article (mail-header-id header)))
3018                    (t
3019                     ;; It is an extracted pseudo-article.
3020                     (setq article 'pseudo)
3021                     (gnus-request-pseudo-article header))))
3022
3023                 (let ((method (gnus-find-method-for-group
3024                                gnus-newsgroup-name)))
3025                   (when (and (eq (car method) 'nneething)
3026                              (vectorp header))
3027                     (let ((dir (concat
3028                                 (file-name-as-directory
3029                                  (or (cadr (assq 'nneething-address method))
3030                                      (nth 1 method)))
3031                                 (mail-header-subject header))))
3032                       (when (file-directory-p dir)
3033                         (setq article 'nneething)
3034                         (gnus-group-enter-directory dir))))))))
3035
3036           (cond
3037            ;; Refuse to select canceled articles.
3038            ((and (numberp article)
3039                  gnus-summary-buffer
3040                  (get-buffer gnus-summary-buffer)
3041                  (gnus-buffer-exists-p gnus-summary-buffer)
3042                  (eq (cdr (save-excursion
3043                             (set-buffer gnus-summary-buffer)
3044                             (assq article gnus-newsgroup-reads)))
3045                      gnus-canceled-mark))
3046             nil)
3047            ;; We first check `gnus-original-article-buffer'.
3048            ((and (get-buffer gnus-original-article-buffer)
3049                  (numberp article)
3050                  (save-excursion
3051                    (set-buffer gnus-original-article-buffer)
3052                    (and (equal (car gnus-original-article) group)
3053                         (eq (cdr gnus-original-article) article))))
3054             (insert-buffer-substring gnus-original-article-buffer)
3055             'article)
3056            ;; Check the backlog.
3057            ((and gnus-keep-backlog
3058                  (gnus-backlog-request-article group article (current-buffer)))
3059             'article)
3060            ;; Check asynchronous pre-fetch.
3061            ((gnus-async-request-fetched-article group article (current-buffer))
3062             (gnus-async-prefetch-next group article gnus-summary-buffer)
3063             (when (and (numberp article) gnus-keep-backlog)
3064               (gnus-backlog-enter-article group article (current-buffer)))
3065             'article)
3066            ;; Check the cache.
3067            ((and gnus-use-cache
3068                  (numberp article)
3069                  (gnus-cache-request-article article group))
3070             'article)
3071            ;; Get the article and put into the article buffer.
3072            ((or (stringp article) (numberp article))
3073             (let ((gnus-override-method
3074                    (and (stringp article) gnus-refer-article-method))
3075                   (buffer-read-only nil))
3076               (erase-buffer)
3077               (gnus-kill-all-overlays)
3078               (gnus-check-group-server)
3079               (when (gnus-request-article article group (current-buffer))
3080                 (when (numberp article)
3081                   (gnus-async-prefetch-next group article gnus-summary-buffer)
3082                   (when gnus-keep-backlog
3083                     (gnus-backlog-enter-article
3084                      group article (current-buffer))))
3085                 'article)))
3086            ;; It was a pseudo.
3087            (t article)))
3088
3089       ;; Associate this article with the current summary buffer.
3090       (setq gnus-article-current-summary gnus-summary-buffer)
3091
3092       ;; Take the article from the original article buffer
3093       ;; and place it in the buffer it's supposed to be in.
3094       (when (and (get-buffer gnus-article-buffer)
3095                  (equal (buffer-name (current-buffer))
3096                         (buffer-name (get-buffer gnus-article-buffer))))
3097         (save-excursion
3098           (if (get-buffer gnus-original-article-buffer)
3099               (set-buffer gnus-original-article-buffer)
3100             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
3101             (buffer-disable-undo)
3102             (setq major-mode 'gnus-original-article-mode)
3103             (setq buffer-read-only t))
3104           (let (buffer-read-only)
3105             (erase-buffer)
3106             (insert-buffer-substring gnus-article-buffer))
3107           (setq gnus-original-article (cons group article)))
3108
3109         ;; Decode charsets.
3110         (run-hooks 'gnus-article-decode-hook)
3111         ;; Mark article as decoded or not.
3112         (setq gnus-article-decoded-p gnus-article-decode-hook))
3113
3114       ;; Update sparse articles.
3115       (when (and do-update-line
3116                  (or (numberp article)
3117                      (stringp article)))
3118         (let ((buf (current-buffer)))
3119           (set-buffer gnus-summary-buffer)
3120           (gnus-summary-update-article do-update-line sparse-header)
3121           (gnus-summary-goto-subject do-update-line nil t)
3122           (set-window-point (get-buffer-window (current-buffer) t)
3123                             (point))
3124           (set-buffer buf))))))
3125
3126 ;;;
3127 ;;; Article editing
3128 ;;;
3129
3130 (defcustom gnus-article-edit-mode-hook nil
3131   "Hook run in article edit mode buffers."
3132   :group 'gnus-article-various
3133   :type 'hook)
3134
3135 (defvar gnus-article-edit-done-function nil)
3136
3137 (defvar gnus-article-edit-mode-map nil)
3138
3139 ;; Should we be using derived.el for this?
3140 (unless gnus-article-edit-mode-map
3141   (setq gnus-article-edit-mode-map (make-sparse-keymap))
3142   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
3143
3144   (gnus-define-keys gnus-article-edit-mode-map
3145     "\C-c\C-c" gnus-article-edit-done
3146     "\C-c\C-k" gnus-article-edit-exit)
3147
3148   (gnus-define-keys (gnus-article-edit-wash-map
3149                      "\C-c\C-w" gnus-article-edit-mode-map)
3150     "f" gnus-article-edit-full-stops))
3151
3152 (defun gnus-article-edit-mode ()
3153   "Major mode for editing articles.
3154 This is an extended text-mode.
3155
3156 \\{gnus-article-edit-mode-map}"
3157   (interactive)
3158   (setq major-mode 'gnus-article-edit-mode)
3159   (setq mode-name "Article Edit")
3160   (use-local-map gnus-article-edit-mode-map)
3161   (make-local-variable 'gnus-article-edit-done-function)
3162   (make-local-variable 'gnus-prev-winconf)
3163   (setq buffer-read-only nil)
3164   (buffer-enable-undo)
3165   (widen)
3166   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
3167
3168 (defun gnus-article-edit (&optional force)
3169   "Edit the current article.
3170 This will have permanent effect only in mail groups.
3171 If FORCE is non-nil, allow editing of articles even in read-only
3172 groups."
3173   (interactive "P")
3174   (when (and (not force)
3175              (gnus-group-read-only-p))
3176     (error "The current newsgroup does not support article editing"))
3177   (gnus-article-date-original)
3178   (gnus-article-edit-article
3179    `(lambda (no-highlight)
3180       (gnus-summary-edit-article-done
3181        ,(or (mail-header-references gnus-current-headers) "")
3182        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
3183
3184 (defun gnus-article-edit-article (exit-func)
3185   "Start editing the contents of the current article buffer."
3186   (let ((winconf (current-window-configuration)))
3187     (set-buffer gnus-article-buffer)
3188     (gnus-article-edit-mode)
3189     (gnus-article-delete-text-of-type 'annotation)
3190     (gnus-set-text-properties (point-min) (point-max) nil)
3191     (gnus-configure-windows 'edit-article)
3192     (setq gnus-article-edit-done-function exit-func)
3193     (setq gnus-prev-winconf winconf)
3194     (gnus-message 6 "C-c C-c to end edits")))
3195
3196 (defun gnus-article-edit-done (&optional arg)
3197   "Update the article edits and exit."
3198   (interactive "P")
3199   (save-excursion
3200     (save-restriction
3201       (widen)
3202       (when (article-goto-body)
3203         (let ((lines (count-lines (point) (point-max)))
3204               (length (- (point-max) (point)))
3205               (case-fold-search t)
3206               (body (copy-marker (point))))
3207           (goto-char (point-min))
3208           (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
3209             (delete-region (match-beginning 1) (match-end 1))
3210             (insert (number-to-string length)))
3211           (goto-char (point-min))
3212           (when (re-search-forward
3213                  "^x-content-length:[ \t]\\([0-9]+\\)" body t)
3214             (delete-region (match-beginning 1) (match-end 1))
3215             (insert (number-to-string length)))
3216           (goto-char (point-min))
3217           (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
3218             (delete-region (match-beginning 1) (match-end 1))
3219             (insert (number-to-string lines)))))))
3220   (let ((func gnus-article-edit-done-function)
3221         (buf (current-buffer))
3222         (start (window-start)))
3223     (gnus-article-edit-exit)
3224     (save-excursion
3225       (set-buffer buf)
3226       (let ((buffer-read-only nil))
3227         (funcall func arg))
3228       ;; The cache and backlog have to be flushed somewhat.
3229       (when gnus-keep-backlog
3230         (gnus-backlog-remove-article
3231          (car gnus-article-current) (cdr gnus-article-current)))
3232       ;; Flush original article as well.
3233       (save-excursion
3234         (when (get-buffer gnus-original-article-buffer)
3235           (set-buffer gnus-original-article-buffer)
3236           (setq gnus-original-article nil)))
3237       (when gnus-use-cache
3238         (gnus-cache-update-article
3239          (car gnus-article-current) (cdr gnus-article-current))))
3240     (set-buffer buf)
3241     (set-window-start (get-buffer-window buf) start)
3242     (set-window-point (get-buffer-window buf) (point))))
3243
3244 (defun gnus-article-edit-exit ()
3245   "Exit the article editing without updating."
3246   (interactive)
3247   ;; We remove all text props from the article buffer.
3248   (let ((buf (format "%s" (buffer-string)))
3249         (curbuf (current-buffer))
3250         (p (point))
3251         (window-start (window-start)))
3252     (erase-buffer)
3253     (insert buf)
3254     (let ((winconf gnus-prev-winconf))
3255       (gnus-article-mode)
3256       (set-window-configuration winconf)
3257       ;; Tippy-toe some to make sure that point remains where it was.
3258       (save-current-buffer
3259         (set-buffer curbuf)
3260         (set-window-start (get-buffer-window (current-buffer)) window-start)
3261         (goto-char p)))))
3262
3263 (defun gnus-article-edit-full-stops ()
3264   "Interactively repair spacing at end of sentences."
3265   (interactive)
3266   (save-excursion
3267     (goto-char (point-min))
3268     (search-forward-regexp "^$" nil t)
3269     (let ((case-fold-search nil))
3270       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
3271
3272 ;;;
3273 ;;; Article highlights
3274 ;;;
3275
3276 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
3277
3278 ;;; Internal Variables:
3279
3280 (defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"
3281   "Regular expression that matches URLs."
3282   :group 'gnus-article-buttons
3283   :type 'regexp)
3284
3285 (defcustom gnus-button-alist
3286   `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
3287      0 t gnus-button-message-id 2)
3288     ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
3289     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
3290      1 t
3291      gnus-button-fetch-group 4)
3292     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
3293     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
3294      t gnus-button-message-id 3)
3295     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
3296     ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
3297     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
3298     ;; This is how URLs _should_ be embedded in text...
3299     ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
3300     ;; Raw URLs.
3301     (,gnus-button-url-regexp 0 t gnus-button-url 0))
3302   "*Alist of regexps matching buttons in article bodies.
3303
3304 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
3305 REGEXP: is the string matching text around the button,
3306 BUTTON: is the number of the regexp grouping actually matching the button,
3307 FORM: is a lisp expression which must eval to true for the button to
3308 be added,
3309 CALLBACK: is the function to call when the user push this button, and each
3310 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
3311
3312 CALLBACK can also be a variable, in that case the value of that
3313 variable it the real callback function."
3314   :group 'gnus-article-buttons
3315   :type '(repeat (list regexp
3316                        (integer :tag "Button")
3317                        (sexp :tag "Form")
3318                        (function :tag "Callback")
3319                        (repeat :tag "Par"
3320                                :inline t
3321                                (integer :tag "Regexp group")))))
3322
3323 (defcustom gnus-header-button-alist
3324   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
3325      0 t gnus-button-message-id 0)
3326     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
3327     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
3328      0 t gnus-button-mailto 0)
3329     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3330     ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3331     ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
3332     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
3333      gnus-button-message-id 3))
3334   "*Alist of headers and regexps to match buttons in article heads.
3335
3336 This alist is very similar to `gnus-button-alist', except that each
3337 alist has an additional HEADER element first in each entry:
3338
3339 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
3340
3341 HEADER is a regexp to match a header.  For a fuller explanation, see
3342 `gnus-button-alist'."
3343   :group 'gnus-article-buttons
3344   :group 'gnus-article-headers
3345   :type '(repeat (list (regexp :tag "Header")
3346                        regexp
3347                        (integer :tag "Button")
3348                        (sexp :tag "Form")
3349                        (function :tag "Callback")
3350                        (repeat :tag "Par"
3351                                :inline t
3352                                (integer :tag "Regexp group")))))
3353
3354 (defvar gnus-button-regexp nil)
3355 (defvar gnus-button-marker-list nil)
3356 ;; Regexp matching any of the regexps from `gnus-button-alist'.
3357
3358 (defvar gnus-button-last nil)
3359 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
3360
3361 ;;; Commands:
3362
3363 (defun gnus-article-push-button (event)
3364   "Check text under the mouse pointer for a callback function.
3365 If the text under the mouse pointer has a `gnus-callback' property,
3366 call it with the value of the `gnus-data' text property."
3367   (interactive "e")
3368   (set-buffer (window-buffer (posn-window (event-start event))))
3369   (let* ((pos (posn-point (event-start event)))
3370          (data (get-text-property pos 'gnus-data))
3371          (fun (get-text-property pos 'gnus-callback)))
3372     (goto-char pos)
3373     (when fun
3374       (funcall fun data))))
3375
3376 (defun gnus-article-press-button ()
3377   "Check text at point for a callback function.
3378 If the text at point has a `gnus-callback' property,
3379 call it with the value of the `gnus-data' text property."
3380   (interactive)
3381   (let* ((data (get-text-property (point) 'gnus-data))
3382          (fun (get-text-property (point) 'gnus-callback)))
3383     (when fun
3384       (funcall fun data))))
3385
3386 (defun gnus-article-highlight (&optional force)
3387   "Highlight current article.
3388 This function calls `gnus-article-highlight-headers',
3389 `gnus-article-highlight-citation',
3390 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
3391 do the highlighting.  See the documentation for those functions."
3392   (interactive (list 'force))
3393   (gnus-article-highlight-headers)
3394   (gnus-article-highlight-citation force)
3395   (gnus-article-highlight-signature)
3396   (gnus-article-add-buttons force)
3397   (gnus-article-add-buttons-to-head))
3398
3399 (defun gnus-article-highlight-some (&optional force)
3400   "Highlight current article.
3401 This function calls `gnus-article-highlight-headers',
3402 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
3403 do the highlighting.  See the documentation for those functions."
3404   (interactive (list 'force))
3405   (gnus-article-highlight-headers)
3406   (gnus-article-highlight-signature)
3407   (gnus-article-add-buttons))
3408
3409 (defun gnus-article-highlight-headers ()
3410   "Highlight article headers as specified by `gnus-header-face-alist'."
3411   (interactive)
3412   (save-excursion
3413     (set-buffer gnus-article-buffer)
3414     (save-restriction
3415       (let ((alist gnus-header-face-alist)
3416             (buffer-read-only nil)
3417             (case-fold-search t)
3418             (inhibit-point-motion-hooks t)
3419             entry regexp header-face field-face from hpoints fpoints)
3420         (message-narrow-to-head)
3421         (while (setq entry (pop alist))
3422           (goto-char (point-min))
3423           (setq regexp (concat "^\\("
3424                                (if (string-equal "" (nth 0 entry))
3425                                    "[^\t ]"
3426                                  (nth 0 entry))
3427                                "\\)")
3428                 header-face (nth 1 entry)
3429                 field-face (nth 2 entry))
3430           (while (and (re-search-forward regexp nil t)
3431                       (not (eobp)))
3432             (beginning-of-line)
3433             (setq from (point))
3434             (unless (search-forward ":" nil t)
3435               (forward-char 1))
3436             (when (and header-face
3437                        (not (memq (point) hpoints)))
3438               (push (point) hpoints)
3439               (gnus-put-text-property from (point) 'face header-face))
3440             (when (and field-face
3441                        (not (memq (setq from (point)) fpoints)))
3442               (push from fpoints)
3443               (if (re-search-forward "^[^ \t]" nil t)
3444                   (forward-char -2)
3445                 (goto-char (point-max)))
3446               (gnus-put-text-property from (point) 'face field-face))))))))
3447
3448 (defun gnus-article-highlight-signature ()
3449   "Highlight the signature in an article.
3450 It does this by highlighting everything after
3451 `gnus-signature-separator' using `gnus-signature-face'."
3452   (interactive)
3453   (save-excursion
3454     (set-buffer gnus-article-buffer)
3455     (let ((buffer-read-only nil)
3456           (inhibit-point-motion-hooks t))
3457       (save-restriction
3458         (when (and gnus-signature-face
3459                    (gnus-article-narrow-to-signature))
3460           (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
3461                             'face gnus-signature-face)
3462           (widen)
3463           (gnus-article-search-signature)
3464           (let ((start (match-beginning 0))
3465                 (end (set-marker (make-marker) (1+ (match-end 0)))))
3466             (gnus-article-add-button start (1- end) 'gnus-signature-toggle
3467                                      end)))))))
3468
3469 (defun gnus-button-in-region-p (b e prop)
3470   "Say whether PROP exists in the region."
3471   (text-property-not-all b e prop nil))
3472
3473 (defun gnus-article-add-buttons (&optional force)
3474   "Find external references in the article and make buttons of them.
3475 \"External references\" are things like Message-IDs and URLs, as
3476 specified by `gnus-button-alist'."
3477   (interactive (list 'force))
3478   (save-excursion
3479     (set-buffer gnus-article-buffer)
3480     (let ((buffer-read-only nil)
3481           (inhibit-point-motion-hooks t)
3482           (case-fold-search t)
3483           (alist gnus-button-alist)
3484           beg entry regexp)
3485       ;; Remove all old markers.
3486       (let (marker entry)
3487         (while (setq marker (pop gnus-button-marker-list))
3488           (goto-char marker)
3489           (when (setq entry (gnus-button-entry))
3490             (put-text-property (match-beginning (nth 1 entry))
3491                                (match-end (nth 1 entry))
3492                                'gnus-callback nil))
3493           (set-marker marker nil)))
3494       ;; We skip the headers.
3495       (article-goto-body)
3496       (setq beg (point))
3497       (while (setq entry (pop alist))
3498         (setq regexp (car entry))
3499         (goto-char beg)
3500         (while (re-search-forward regexp nil t)
3501           (let* ((start (and entry (match-beginning (nth 1 entry))))
3502                  (end (and entry (match-end (nth 1 entry))))
3503                  (from (match-beginning 0)))
3504             (when (and (or (eq t (nth 2 entry))
3505                            (eval (nth 2 entry)))
3506                        (not (gnus-button-in-region-p
3507                              start end 'gnus-callback)))
3508               ;; That optional form returned non-nil, so we add the
3509               ;; button.
3510               (gnus-article-add-button
3511                start end 'gnus-button-push
3512                (car (push (set-marker (make-marker) from)
3513                           gnus-button-marker-list))))))))))
3514
3515 ;; Add buttons to the head of an article.
3516 (defun gnus-article-add-buttons-to-head ()
3517   "Add buttons to the head of the article."
3518   (interactive)
3519   (save-excursion
3520     (set-buffer gnus-article-buffer)
3521     (let ((buffer-read-only nil)
3522           (inhibit-point-motion-hooks t)
3523           (case-fold-search t)
3524           (alist gnus-header-button-alist)
3525           entry beg end)
3526       (nnheader-narrow-to-headers)
3527       (while alist
3528         ;; Each alist entry.
3529         (setq entry (car alist)
3530               alist (cdr alist))
3531         (goto-char (point-min))
3532         (while (re-search-forward (car entry) nil t)
3533           ;; Each header matching the entry.
3534           (setq beg (match-beginning 0))
3535           (setq end (or (and (re-search-forward "^[^ \t]" nil t)
3536                              (match-beginning 0))
3537                         (point-max)))
3538           (goto-char beg)
3539           (while (re-search-forward (nth 1 entry) end t)
3540             ;; Each match within a header.
3541             (let* ((entry (cdr entry))
3542                    (start (match-beginning (nth 1 entry)))
3543                    (end (match-end (nth 1 entry)))
3544                    (form (nth 2 entry)))
3545               (goto-char (match-end 0))
3546               (when (eval form)
3547                 (gnus-article-add-button
3548                  start end (nth 3 entry)
3549                  (buffer-substring (match-beginning (nth 4 entry))
3550                                    (match-end (nth 4 entry)))))))
3551           (goto-char end))))
3552     (widen)))
3553
3554 ;;; External functions:
3555
3556 (defun gnus-article-add-button (from to fun &optional data)
3557   "Create a button between FROM and TO with callback FUN and data DATA."
3558   (when gnus-article-button-face
3559     (gnus-overlay-put (gnus-make-overlay from to)
3560                       'face gnus-article-button-face))
3561   (gnus-add-text-properties
3562    from to
3563    (nconc (and gnus-article-mouse-face
3564                (list gnus-mouse-face-prop gnus-article-mouse-face))
3565           (list 'gnus-callback fun)
3566           (and data (list 'gnus-data data))))
3567   (widget-convert-button 'link from to :action 'gnus-widget-press-button
3568                          :button-keymap gnus-widget-button-keymap))
3569
3570 ;;; Internal functions:
3571
3572 (defun gnus-article-set-globals ()
3573   (save-excursion
3574     (set-buffer gnus-summary-buffer)
3575     (gnus-set-global-variables)))
3576
3577 (defun gnus-signature-toggle (end)
3578   (save-excursion
3579     (set-buffer gnus-article-buffer)
3580     (let ((buffer-read-only nil)
3581           (inhibit-point-motion-hooks t))
3582       (if (get-text-property end 'invisible)
3583           (gnus-article-unhide-text end (point-max))
3584         (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))
3585
3586 (defun gnus-button-entry ()
3587   ;; Return the first entry in `gnus-button-alist' matching this place.
3588   (let ((alist gnus-button-alist)
3589         (entry nil))
3590     (while alist
3591       (setq entry (pop alist))
3592       (if (looking-at (car entry))
3593           (setq alist nil)
3594         (setq entry nil)))
3595     entry))
3596
3597 (defun gnus-button-push (marker)
3598   ;; Push button starting at MARKER.
3599   (save-excursion
3600     (goto-char marker)
3601     (let* ((entry (gnus-button-entry))
3602            (inhibit-point-motion-hooks t)
3603            (fun (nth 3 entry))
3604            (args (mapcar (lambda (group)
3605                            (let ((string (match-string group)))
3606                              (gnus-set-text-properties
3607                               0 (length string) nil string)
3608                              string))
3609                          (nthcdr 4 entry))))
3610       (cond
3611        ((fboundp fun)
3612         (apply fun args))
3613        ((and (boundp fun)
3614              (fboundp (symbol-value fun)))
3615         (apply (symbol-value fun) args))
3616        (t
3617         (gnus-message 1 "You must define `%S' to use this button"
3618                       (cons fun args)))))))
3619
3620 (defun gnus-button-message-id (message-id)
3621   "Fetch MESSAGE-ID."
3622   (save-excursion
3623     (set-buffer gnus-summary-buffer)
3624     (gnus-summary-refer-article message-id)))
3625
3626 (defun gnus-button-fetch-group (address)
3627   "Fetch GROUP specified by ADDRESS."
3628   (if (not (string-match "[:/]" address))
3629       ;; This is just a simple group url.
3630       (gnus-group-read-ephemeral-group address gnus-select-method)
3631     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
3632                            address))
3633         (error "Can't parse %s" address)
3634       (gnus-group-read-ephemeral-group
3635        (match-string 4 address)
3636        `(nntp ,(match-string 1 address)
3637               (nntp-address ,(match-string 1 address))
3638               (nntp-port-number ,(if (match-end 3)
3639                                      (match-string 3 address)
3640                                    "nntp")))))))
3641
3642 (defun gnus-url-parse-query-string (query &optional downcase)
3643   (let (retval pairs cur key val)
3644     (setq pairs (split-string query "&"))
3645     (while pairs
3646       (setq cur (car pairs)
3647             pairs (cdr pairs))
3648       (if (not (string-match "=" cur))
3649           nil                           ; Grace
3650         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
3651               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
3652         (if downcase
3653             (setq key (downcase key)))
3654         (setq cur (assoc key retval))
3655         (if cur
3656             (setcdr cur (cons val (cdr cur)))
3657           (setq retval (cons (list key val) retval)))))
3658     retval))
3659
3660 (defun gnus-url-unhex (x)
3661   (if (> x ?9)
3662       (if (>= x ?a)
3663           (+ 10 (- x ?a))
3664         (+ 10 (- x ?A)))
3665     (- x ?0)))
3666
3667 (defun gnus-url-unhex-string (str &optional allow-newlines)
3668   "Remove %XXX embedded spaces, etc in a url.
3669 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
3670 decoding of carriage returns and line feeds in the string, which is normally
3671 forbidden in URL encoding."
3672   (setq str (or str ""))
3673   (let ((tmp "")
3674         (case-fold-search t))
3675     (while (string-match "%[0-9a-f][0-9a-f]" str)
3676       (let* ((start (match-beginning 0))
3677              (ch1 (gnus-url-unhex (elt str (+ start 1))))
3678              (code (+ (* 16 ch1)
3679                       (gnus-url-unhex (elt str (+ start 2))))))
3680         (setq tmp (concat
3681                    tmp (substring str 0 start)
3682                    (cond
3683                     (allow-newlines
3684                      (char-to-string code))
3685                     ((or (= code ?\n) (= code ?\r))
3686                      " ")
3687                     (t (char-to-string code))))
3688               str (substring str (match-end 0)))))
3689     (setq tmp (concat tmp str))
3690     tmp))
3691
3692 (defun gnus-url-mailto (url)
3693   ;; Send mail to someone
3694   (when (string-match "mailto:/*\\(.*\\)" url)
3695     (setq url (substring url (match-beginning 1) nil)))
3696   (let (to args subject func)
3697     (if (string-match (regexp-quote "?") url)
3698         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
3699               args (gnus-url-parse-query-string
3700                     (substring url (match-end 0) nil) t))
3701       (setq to (gnus-url-unhex-string url)))
3702     (setq args (cons (list "to" to) args)
3703           subject (cdr-safe (assoc "subject" args)))
3704     (message-mail)
3705     (while args
3706       (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
3707       (if (fboundp func)
3708           (funcall func)
3709         (message-position-on-field (caar args)))
3710       (insert (mapconcat 'identity (cdar args) ", "))
3711       (setq args (cdr args)))
3712     (if subject
3713         (message-goto-body)
3714       (message-goto-subject))))
3715
3716 (defun gnus-button-mailto (address)
3717   ;; Mail to ADDRESS.
3718   (set-buffer (gnus-copy-article-buffer))
3719   (message-reply address))
3720
3721 (defun gnus-button-reply (address)
3722   ;; Reply to ADDRESS.
3723   (message-reply address))
3724
3725 (defun gnus-button-url (address)
3726   "Browse ADDRESS."
3727   ;; In Emacs 20, `browse-url-browser-function' may be an alist.
3728   (if (listp browse-url-browser-function)
3729       (browse-url address)
3730     (funcall browse-url-browser-function address)))
3731
3732 (defun gnus-button-embedded-url (address)
3733   "Browse ADDRESS."
3734   ;; In Emacs 20, `browse-url-browser-function' may be an alist.
3735   (if (listp browse-url-browser-function)
3736       (browse-url (gnus-strip-whitespace address))
3737     (funcall browse-url-browser-function (gnus-strip-whitespace address))))
3738
3739 ;;; Next/prev buttons in the article buffer.
3740
3741 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
3742 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
3743
3744 (defvar gnus-prev-page-map nil)
3745 (unless gnus-prev-page-map
3746   (setq gnus-prev-page-map (make-sparse-keymap))
3747   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
3748   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
3749
3750 (defun gnus-insert-prev-page-button ()
3751   (let ((buffer-read-only nil))
3752     (gnus-eval-format
3753      gnus-prev-page-line-format nil
3754      `(gnus-prev t local-map ,gnus-prev-page-map
3755                  gnus-callback gnus-article-button-prev-page
3756                  article-type annotation))))
3757
3758 (defvar gnus-next-page-map nil)
3759 (unless gnus-next-page-map
3760   (setq gnus-next-page-map (make-keymap))
3761   (suppress-keymap gnus-prev-page-map)
3762   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
3763   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
3764
3765 (defun gnus-button-next-page ()
3766   "Go to the next page."
3767   (interactive)
3768   (let ((win (selected-window)))
3769     (select-window (get-buffer-window gnus-article-buffer t))
3770     (gnus-article-next-page)
3771     (select-window win)))
3772
3773 (defun gnus-button-prev-page ()
3774   "Go to the prev page."
3775   (interactive)
3776   (let ((win (selected-window)))
3777     (select-window (get-buffer-window gnus-article-buffer t))
3778     (gnus-article-prev-page)
3779     (select-window win)))
3780
3781 (defun gnus-insert-next-page-button ()
3782   (let ((buffer-read-only nil))
3783     (gnus-eval-format gnus-next-page-line-format nil
3784                       `(gnus-next
3785                         t local-map ,gnus-next-page-map
3786                         gnus-callback gnus-article-button-next-page
3787                         article-type annotation))))
3788
3789 (defun gnus-article-button-next-page (arg)
3790   "Go to the next page."
3791   (interactive "P")
3792   (let ((win (selected-window)))
3793     (select-window (get-buffer-window gnus-article-buffer t))
3794     (gnus-article-next-page)
3795     (select-window win)))
3796
3797 (defun gnus-article-button-prev-page (arg)
3798   "Go to the prev page."
3799   (interactive "P")
3800   (let ((win (selected-window)))
3801     (select-window (get-buffer-window gnus-article-buffer t))
3802     (gnus-article-prev-page)
3803     (select-window win)))
3804
3805 (defvar gnus-decode-header-methods
3806   '(mail-decode-encoded-word-region)
3807   "List of methods used to decode headers
3808
3809 This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
3810 FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
3811 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
3812 whose names match REGEXP.
3813
3814 For example:
3815 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
3816  mail-decode-encoded-word-region
3817  (\"chinese\" . rfc1843-decode-region))
3818 ")
3819
3820 (defvar gnus-decode-header-methods-cache nil)
3821
3822 (defun gnus-multi-decode-header (start end)
3823   "Apply the functions from `gnus-encoded-word-methods' that match."
3824   (unless (and gnus-decode-header-methods-cache
3825                (eq gnus-newsgroup-name
3826                    (car gnus-decode-header-methods-cache)))
3827     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
3828     (mapc '(lambda (x)
3829              (if (symbolp x)
3830                  (nconc gnus-decode-header-methods-cache (list x))
3831                (if (and gnus-newsgroup-name
3832                         (string-match (car x) gnus-newsgroup-name))
3833                    (nconc gnus-decode-header-methods-cache
3834                           (list (cdr x))))))
3835           gnus-decode-header-methods))
3836   (let ((xlist gnus-decode-header-methods-cache))
3837     (pop xlist)
3838     (save-restriction
3839       (narrow-to-region start end)
3840       (while xlist
3841         (funcall (pop xlist) (point-min) (point-max))))))
3842
3843 (gnus-ems-redefine)
3844
3845 (provide 'gnus-art)
3846
3847 (run-hooks 'gnus-art-load-hook)
3848
3849 ;;; gnus-art.el ends here