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

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