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

   1 ;;; gnus-art.el --- article mode commands for Semi-gnus
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000 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 and/or Cc header." long-to)
 185               (const :tag "Multiple To and/or Cc 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 'gnus-bitmap)))
 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                     (cc (message-fetch-field "cc")))
1238                 (when (> (length to) 1024)
1239                   (gnus-article-hide-header "to"))
1240                 (when (> (length cc) 1024)
1241                   (gnus-article-hide-header "cc"))))
1242              ((eq elem 'many-to)
1243               (let ((to-count 0)
1244                     (cc-count 0))
1245                 (goto-char (point-min))
1246                 (while (re-search-forward "^to:" nil t)
1247                   (setq to-count (1+ to-count)))
1248                 (when (> to-count 1)
1249                   (while (> to-count 0)
1250                     (goto-char (point-min))
1251                     (save-restriction
1252                       (re-search-forward "^to:" nil nil to-count)
1253                       (forward-line -1)
1254                       (narrow-to-region (point) (point-max))
1255                       (gnus-article-hide-header "to"))
1256                     (setq to-count (1- to-count))))
1257                 (goto-char (point-min))
1258                 (while (re-search-forward "^cc:" nil t)
1259                   (setq cc-count (1+ cc-count)))
1260                 (when (> cc-count 1)
1261                   (while (> cc-count 0)
1262                     (goto-char (point-min))
1263                     (save-restriction
1264                       (re-search-forward "^cc:" nil nil cc-count)
1265                       (forward-line -1)
1266                       (narrow-to-region (point) (point-max))
1267                       (gnus-article-hide-header "cc"))
1268                     (setq cc-count (1- cc-count)))))))))))))
1269
1270 (defun gnus-article-hide-header (header)
1271   (save-excursion
1272     (goto-char (point-min))
1273     (when (re-search-forward (concat "^" header ":") nil t)
1274       (gnus-article-hide-text-type
1275        (progn (beginning-of-line) (point))
1276        (progn
1277          (end-of-line)
1278          (if (re-search-forward "^[^ \t]" nil t)
1279              (match-beginning 0)
1280            (point-max)))
1281        'boring-headers))))
1282
1283 (defun article-toggle-headers (&optional arg)
1284   "Toggle hiding of headers.  If given a negative prefix, always show;
1285 if given a positive prefix, always hide."
1286   (interactive (gnus-article-hidden-arg))
1287   (let ((force (when (numberp arg)
1288                  (cond ((> arg 0) 'always-hide)
1289                        ((< arg 0) 'always-show))))
1290         (window (get-buffer-window gnus-article-buffer))
1291         (header-end (point-min))
1292         header-start field-end field-start
1293         (inhibit-point-motion-hooks t)
1294         (inhibit-read-only t)
1295         buffer-read-only)
1296     (save-restriction
1297       (widen)
1298       (while (and (setq header-start
1299                         (text-property-any header-end (point-max)
1300                                            'article-treated-header t))
1301                   (setq header-end
1302                         (text-property-not-all header-start (point-max)
1303                                                'article-treated-header t)))
1304         (setq field-end header-start)
1305         (cond
1306          (;; Hide exposed invisible fields.
1307           (and (not (eq 'always-show force))
1308                (setq field-start
1309                      (text-property-any field-end header-end
1310                                         'exposed-invisible-field t)))
1311           (while (and field-start
1312                       (setq field-end (text-property-not-all
1313                                        field-start header-end
1314                                        'exposed-invisible-field t)))
1315             (add-text-properties field-start field-end gnus-hidden-properties)
1316             (setq field-start (text-property-any field-end header-end
1317                                                  'exposed-invisible-field t)))
1318           (put-text-property header-start header-end
1319                              'exposed-invisible-field nil))
1320          (;; Expose invisible fields.
1321           (and (not (eq 'always-hide force))
1322                (setq field-start
1323                      (text-property-any field-end header-end 'invisible t)))
1324           (while (and field-start
1325                       (setq field-end (text-property-not-all
1326                                        field-start header-end
1327                                        'invisible t)))
1328             ;; If the invisible text is not terminated with newline, we
1329             ;; won't expose it.  Because it may be created by x-face-mule.
1330             ;; BTW, XEmacs sometimes fail in putting a invisible text
1331             ;; property with `gnus-article-hide-text' (really?).  In that
1332             ;; case, the invisible text might be started from the middle of
1333             ;; a line so we will expose the sort of thing.
1334             (when (or (not (or (eq header-start field-start)
1335                                (eq ?\n (char-before field-start))))
1336                       (eq ?\n (char-before field-end)))
1337               (remove-text-properties field-start field-end
1338                                       gnus-hidden-properties)
1339               (put-text-property field-start field-end
1340                                  'exposed-invisible-field t))
1341             (setq field-start (text-property-any field-end header-end
1342                                                  'invisible t))))
1343          (;; Hide fields.
1344           (not (eq 'always-show force))
1345           (narrow-to-region header-start header-end)
1346           (article-hide-headers)
1347           ;; Re-display X-Face image under XEmacs.
1348           (when (and gnus-xemacs
1349                      (gnus-functionp gnus-article-x-face-command))
1350             (let ((func (cadr (assq 'gnus-treat-display-xface
1351                                     gnus-treatment-function-alist)))
1352                   (condition 'head))
1353               (when (and (not gnus-inhibit-treatment)
1354                          func
1355                          (gnus-treat-predicate gnus-treat-display-xface))
1356                 (funcall func)
1357                 (put-text-property header-start header-end 'read-only nil))))
1358           (widen))
1359          ))
1360       (goto-char (point-min))
1361       (when window
1362         (set-window-start window (point-min))))))
1363
1364 (defvar gnus-article-normalized-header-length 40
1365   "Length of normalized headers.")
1366
1367 (defun article-normalize-headers ()
1368   "Make all header lines 40 characters long."
1369   (interactive)
1370   (let ((buffer-read-only nil)
1371         column)
1372     (save-excursion
1373       (save-restriction
1374         (article-narrow-to-head)
1375         (while (not (eobp))
1376           (cond
1377            ((< (setq column (- (gnus-point-at-eol) (point)))
1378                gnus-article-normalized-header-length)
1379             (end-of-line)
1380             (insert (make-string
1381                      (- gnus-article-normalized-header-length column)
1382                      ? )))
1383            ((> column gnus-article-normalized-header-length)
1384             (gnus-put-text-property
1385              (progn
1386                (forward-char gnus-article-normalized-header-length)
1387                (point))
1388              (gnus-point-at-eol)
1389              'invisible t))
1390            (t
1391             ;; Do nothing.
1392             ))
1393           (forward-line 1))))))
1394
1395 (defun article-treat-dumbquotes ()
1396   "Translate M******** sm*rtq**t*s into proper text.
1397 Note that this function guesses whether a character is a sm*rtq**t* or
1398 not, so it should only be used interactively."
1399   (interactive)
1400   (article-translate-strings gnus-article-dumbquotes-map))
1401
1402 (defun article-translate-characters (from to)
1403   "Translate all characters in the body of the article according to FROM and TO.
1404 FROM is a string of characters to translate from; to is a string of
1405 characters to translate to."
1406   (save-excursion
1407     (when (article-goto-body)
1408       (let ((buffer-read-only nil)
1409             (x (make-string 225 ?x))
1410             (i -1))
1411         (while (< (incf i) (length x))
1412           (aset x i i))
1413         (setq i 0)
1414         (while (< i (length from))
1415           (aset x (aref from i) (aref to i))
1416           (incf i))
1417         (translate-region (point) (point-max) x)))))
1418
1419 (defun article-translate-strings (map)
1420   "Translate all string in the body of the article according to MAP.
1421 MAP is an alist where the elements are on the form (\"from\" \"to\")."
1422   (save-excursion
1423     (when (article-goto-body)
1424       (let ((buffer-read-only nil)
1425             elem)
1426         (while (setq elem (pop map))
1427           (save-excursion
1428             (while (search-forward (car elem) nil t)
1429               (replace-match (cadr elem)))))))))
1430
1431 (defun article-treat-overstrike ()
1432   "Translate overstrikes into bold text."
1433   (interactive)
1434   (save-excursion
1435     (when (article-goto-body)
1436       (let ((buffer-read-only nil))
1437         (while (search-forward "\b" nil t)
1438           (let ((next (char-after))
1439                 start end previous)
1440             (backward-char 2)
1441             (setq start (point)
1442                   previous (char-after))
1443             (forward-char 3)
1444             (setq end (point))
1445             (backward-char)
1446             ;; We do the boldification/underlining by hiding the
1447             ;; overstrikes and putting the proper text property
1448             ;; on the letters.
1449             (cond
1450              ((eq next previous)
1451               (gnus-article-hide-text-type start (point) 'overstrike)
1452               (put-text-property (point) end 'face 'bold))
1453              ((eq next ?_)
1454               (gnus-article-hide-text-type
1455                (1- (point)) (1+ (point)) 'overstrike)
1456               (put-text-property
1457                start (1- (point)) 'face 'underline))
1458              ((eq previous ?_)
1459               (gnus-article-hide-text-type start (point) 'overstrike)
1460               (put-text-property
1461                (point) end 'face 'underline)))))))))
1462
1463 (defun article-fill-long-lines ()
1464   "Fill lines that are wider than the window width."
1465   (interactive)
1466   (save-excursion
1467     (let ((buffer-read-only nil)
1468           (width (window-width (get-buffer-window (current-buffer)))))
1469       (save-restriction
1470         (article-goto-body)
1471         (let ((adaptive-fill-mode nil))
1472           (while (not (eobp))
1473             (end-of-line)
1474             (when (>= (current-column) (min fill-column width))
1475               (narrow-to-region (point) (gnus-point-at-bol))
1476               (fill-paragraph nil)
1477               (goto-char (point-max))
1478               (widen))
1479             (forward-line 1)))))))
1480
1481 (defun article-capitalize-sentences ()
1482   "Capitalize the first word in each sentence."
1483   (interactive)
1484   (save-excursion
1485     (let ((buffer-read-only nil)
1486           (paragraph-start "^[\n\^L]"))
1487       (article-goto-body)
1488       (while (not (eobp))
1489         (capitalize-word 1)
1490         (forward-sentence)))))
1491
1492 (defun article-remove-cr ()
1493   "Remove trailing CRs and then translate remaining CRs into LFs."
1494   (interactive)
1495   (save-excursion
1496     (let ((buffer-read-only nil))
1497       (goto-char (point-min))
1498       (while (re-search-forward "\r+$" nil t)
1499         (replace-match "" t t))
1500       (goto-char (point-min))
1501       (while (search-forward "\r" nil t)
1502         (replace-match "\n" t t)))))
1503
1504 (defun article-remove-trailing-blank-lines ()
1505   "Remove all trailing blank lines from the article."
1506   (interactive)
1507   (save-excursion
1508     (let ((buffer-read-only nil))
1509       (goto-char (point-max))
1510       (delete-region
1511        (point)
1512        (progn
1513          (while (and (not (bobp))
1514                      (looking-at "^[ \t]*$")
1515                      (not (gnus-annotation-in-region-p
1516                            (point) (gnus-point-at-eol))))
1517            (forward-line -1))
1518          (forward-line 1)
1519          (point))))))
1520
1521 (defun article-display-x-face (&optional force)
1522   "Look for an X-Face header and display it if present."
1523   (interactive (list 'force))
1524   (save-excursion
1525     ;; Delete the old process, if any.
1526     (when (process-status "article-x-face")
1527       (delete-process "article-x-face"))
1528     (let ((inhibit-point-motion-hooks t)
1529           (case-fold-search t)
1530           from last)
1531       (save-restriction
1532         (article-narrow-to-head)
1533         (goto-char (point-min))
1534         (setq from (message-fetch-field "from"))
1535         (goto-char (point-min))
1536         (while (and gnus-article-x-face-command
1537                     (not last)
1538                     (or force
1539                         ;; Check whether this face is censored.
1540                         (not gnus-article-x-face-too-ugly)
1541                         (and gnus-article-x-face-too-ugly from
1542                              (not (string-match gnus-article-x-face-too-ugly
1543                                                 from))))
1544                     ;; Has to be present.
1545                     (re-search-forward "^X-Face:[ \t]*" nil t))
1546           ;; This used to try to do multiple faces (`while' instead of
1547           ;; `when' above), but (a) sending multiple EOFs to xv doesn't
1548           ;; work (b) it can crash some versions of Emacs (c) are
1549           ;; multiple faces really something to encourage?
1550           (when (stringp gnus-article-x-face-command)
1551             (setq last t))
1552           ;; We now have the area of the buffer where the X-Face is stored.
1553           (save-excursion
1554             (let ((beg (point))
1555                   (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
1556               ;; We display the face.
1557               (if (symbolp gnus-article-x-face-command)
1558                   ;; The command is a lisp function, so we call it.
1559                   (if (gnus-functionp gnus-article-x-face-command)
1560                       (funcall gnus-article-x-face-command beg end)
1561                     (error "%s is not a function" gnus-article-x-face-command))
1562                 ;; The command is a string, so we interpret the command
1563                 ;; as a, well, command, and fork it off.
1564                 (let ((process-connection-type nil))
1565                   (process-kill-without-query
1566                    (start-process
1567                     "article-x-face" nil shell-file-name shell-command-switch
1568                     gnus-article-x-face-command))
1569                   (process-send-region "article-x-face" beg end)
1570                   (process-send-eof "article-x-face"))))))))))
1571
1572 (defun article-decode-mime-words ()
1573   "Decode all MIME-encoded words in the article."
1574   (interactive)
1575   (save-excursion
1576     (set-buffer gnus-article-buffer)
1577     (let ((inhibit-point-motion-hooks t)
1578           buffer-read-only
1579           (mail-parse-charset gnus-newsgroup-charset)
1580           (mail-parse-ignored-charsets
1581            (save-excursion (set-buffer gnus-summary-buffer)
1582                            gnus-newsgroup-ignored-charsets)))
1583       (mail-decode-encoded-word-region (point-min) (point-max)))))
1584
1585 (defun article-decode-charset (&optional prompt)
1586   "Decode charset-encoded text in the article.
1587 If PROMPT (the prefix), prompt for a coding system to use."
1588   (interactive "P")
1589   (let ((inhibit-point-motion-hooks t) (case-fold-search t)
1590         buffer-read-only
1591         (mail-parse-charset gnus-newsgroup-charset)
1592         (mail-parse-ignored-charsets
1593          (save-excursion (condition-case nil
1594                              (set-buffer gnus-summary-buffer)
1595                            (error))
1596                          gnus-newsgroup-ignored-charsets))
1597         ct cte ctl charset)
1598   (save-excursion
1599     (save-restriction
1600       (article-narrow-to-head)
1601       (setq ct (message-fetch-field "Content-Type" t)
1602             cte (message-fetch-field "Content-Transfer-Encoding" t)
1603             ctl (and ct (ignore-errors
1604                           (mail-header-parse-content-type ct)))
1605             charset (cond
1606                      (prompt
1607                       (mm-read-coding-system "Charset to decode: "))
1608                      (ctl
1609                       (mail-content-type-get ctl 'charset))))
1610       (when cte
1611         (setq cte (mail-header-strip cte)))
1612       (if (and ctl (not (string-match "/" (car ctl))))
1613           (setq ctl nil))
1614       (goto-char (point-max)))
1615     (forward-line 1)
1616     (save-restriction
1617       (narrow-to-region (point) (point-max))
1618       (when (and (or (not ctl)
1619                      (equal (car ctl) "text/plain")))
1620         (mm-decode-body
1621          charset (and cte (intern (downcase
1622                                    (gnus-strip-whitespace cte))))
1623          (car ctl)))))))
1624
1625 (defun article-decode-encoded-words ()
1626   "Remove encoded-word encoding from headers."
1627   (let (buffer-read-only)
1628     (let ((charset (save-excursion
1629                      (set-buffer gnus-summary-buffer)
1630                      default-mime-charset)))
1631       (mime-decode-header-in-buffer charset)
1632       )))
1633
1634 (defun article-de-quoted-unreadable (&optional force)
1635   "Translate a quoted-printable-encoded article.
1636 If FORCE, decode the article whether it is marked as quoted-printable
1637 or not."
1638   (interactive (list 'force))
1639   (save-excursion
1640     (let ((buffer-read-only nil)
1641           (type (gnus-fetch-field "content-transfer-encoding"))
1642           (charset gnus-newsgroup-charset))
1643       (when (or force
1644                 (and type (string-match "quoted-printable" (downcase type))))
1645         (article-goto-body)
1646         (quoted-printable-decode-region (point) (point-max) charset)))))
1647
1648 (eval-when-compile
1649   (require 'rfc1843))
1650
1651 (defun article-decode-HZ ()
1652   "Translate a HZ-encoded article."
1653   (interactive)
1654   (require 'rfc1843)
1655   (save-excursion
1656     (let ((buffer-read-only nil))
1657       (rfc1843-decode-region (point-min) (point-max)))))
1658
1659 (defun article-hide-list-identifiers ()
1660   "Remove list identifies from the Subject header.
1661 The `gnus-list-identifiers' variable specifies what to do."
1662   (interactive)
1663   (save-excursion
1664     (save-restriction
1665       (let ((inhibit-point-motion-hooks t)
1666             buffer-read-only)
1667         (article-narrow-to-head)
1668         (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers
1669                         (mapconcat 'identity gnus-list-identifiers " *\\|"))))
1670           (when regexp
1671             (goto-char (point-min))
1672             (when (re-search-forward
1673                    (concat "^Subject: +\\(Re: +\\)?\\(" regexp " *\\)")
1674                    nil t)
1675               (delete-region (match-beginning 2) (match-end 0)))))))))
1676
1677 (defun article-hide-pgp ()
1678   "Remove any PGP headers and signatures in the current article."
1679   (interactive)
1680   (save-excursion
1681     (save-restriction
1682       (let ((inhibit-point-motion-hooks t)
1683             buffer-read-only beg end)
1684         (article-goto-body)
1685         ;; Hide the "header".
1686         (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
1687           (push 'pgp gnus-article-wash-types)
1688           (delete-region (match-beginning 0) (match-end 0))
1689           ;; Remove armor headers (rfc2440 6.2)
1690           (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t)
1691                                      (point)))
1692           (setq beg (point))
1693           ;; Hide the actual signature.
1694           (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
1695                (setq end (1+ (match-beginning 0)))
1696                (delete-region
1697                 end
1698                 (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
1699                     (match-end 0)
1700                   ;; Perhaps we shouldn't hide to the end of the buffer
1701                   ;; if there is no end to the signature?
1702                   (point-max))))
1703           ;; Hide "- " PGP quotation markers.
1704           (when (and beg end)
1705             (narrow-to-region beg end)
1706             (goto-char (point-min))
1707             (while (re-search-forward "^- " nil t)
1708               (delete-region
1709                (match-beginning 0) (match-end 0)))
1710             (widen))
1711           (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
1712
1713 (defun article-hide-pem (&optional arg)
1714   "Toggle hiding of any PEM headers and signatures in the current article.
1715 If given a negative prefix, always show; if given a positive prefix,
1716 always hide."
1717   (interactive (gnus-article-hidden-arg))
1718   (unless (gnus-article-check-hidden-text 'pem arg)
1719     (save-excursion
1720       (let (buffer-read-only end)
1721         (goto-char (point-min))
1722         ;; Hide the horrendously ugly "header".
1723         (when (and (search-forward
1724                     "\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
1725                     nil t)
1726                    (setq end (1+ (match-beginning 0))))
1727           (push 'pem gnus-article-wash-types)
1728           (gnus-article-hide-text-type
1729            end
1730            (if (search-forward "\n\n" nil t)
1731                (match-end 0)
1732              (point-max))
1733            'pem)
1734           ;; Hide the trailer as well
1735           (when (search-forward "\n-----END PRIVACY-ENHANCED MESSAGE-----\n"
1736                                 nil t)
1737             (gnus-article-hide-text-type
1738              (match-beginning 0) (match-end 0) 'pem)))))))
1739
1740 (defun article-strip-banner ()
1741   "Strip the banner specified by the `banner' group parameter."
1742   (interactive)
1743   (save-excursion
1744     (save-restriction
1745       (let ((inhibit-point-motion-hooks t)
1746             (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
1747             (gnus-signature-limit nil)
1748             buffer-read-only beg end)
1749         (when banner
1750           (article-goto-body)
1751           (cond
1752            ((eq banner 'signature)
1753             (when (gnus-article-narrow-to-signature)
1754               (widen)
1755               (forward-line -1)
1756               (delete-region (point) (point-max))))
1757            ((stringp banner)
1758             (while (re-search-forward banner nil t)
1759               (delete-region (match-beginning 0) (match-end 0))))))))))
1760
1761 (defun article-babel ()
1762   "Translate article using an online translation service."
1763   (interactive)
1764   (require 'babel)
1765   (save-excursion
1766     (set-buffer gnus-article-buffer)
1767     (when (article-goto-body)
1768       (let* ((buffer-read-only nil)
1769              (start (point))
1770              (end (point-max))
1771              (orig (buffer-substring start end))
1772              (trans (babel-as-string orig)))
1773         (save-restriction
1774           (narrow-to-region start end)
1775           (delete-region start end)
1776           (insert trans))))))
1777
1778 (defun article-hide-signature (&optional arg)
1779   "Hide the signature in the current article.
1780 If given a negative prefix, always show; if given a positive prefix,
1781 always hide."
1782   (interactive (gnus-article-hidden-arg))
1783   (save-excursion
1784     (save-restriction
1785       (if (interactive-p)
1786           (progn
1787             (widen)
1788             (article-goto-body))
1789         (goto-char (point-min)))
1790       (unless (gnus-article-check-hidden-text 'signature arg)
1791         (let ((buffer-read-only nil)
1792               (button (point)))
1793           (while (setq button (text-property-any button (point-max)
1794                                                  'gnus-callback
1795                                                  'gnus-signature-toggle))
1796             (setq button (text-property-not-all button (point-max)
1797                                                 'gnus-callback
1798                                                 'gnus-signature-toggle))
1799             (when (and button (not (eobp)))
1800               (gnus-article-hide-text-type
1801                (1+ button)
1802                (next-single-property-change (1+ button) 'mime-view-entity
1803                                             nil (point-max))
1804                'signature))))))))
1805
1806 (defun article-strip-headers-in-body ()
1807   "Strip offensive headers from bodies."
1808   (interactive)
1809   (save-excursion
1810     (article-goto-body)
1811     (let ((case-fold-search t))
1812       (when (looking-at "x-no-archive:")
1813         (gnus-delete-line)))))
1814
1815 (defun article-strip-leading-blank-lines ()
1816   "Remove all blank lines from the beginning of the article."
1817   (interactive)
1818   (save-excursion
1819     (let ((inhibit-point-motion-hooks t)
1820           buffer-read-only)
1821       (when (article-goto-body)
1822         (while (and (not (eobp))
1823                     (looking-at "[ \t]*$"))
1824           (gnus-delete-line))))))
1825
1826 (defun article-narrow-to-head ()
1827   "Narrow the buffer to the head of the message.
1828 Point is left at the beginning of the narrowed-to region."
1829   (narrow-to-region
1830    (goto-char (point-min))
1831    (if (search-forward "\n\n" nil 1)
1832        (1- (point))
1833      (point-max)))
1834   (goto-char (point-min)))
1835
1836 (defun article-goto-body ()
1837   "Place point at the start of the body."
1838   (goto-char (point-min))
1839   (cond
1840    ;; This variable is only bound when dealing with separate
1841    ;; MIME body parts.
1842    (article-goto-body-goes-to-point-min-p
1843     t)
1844    ((search-forward "\n\n" nil t)
1845     t)
1846    (t
1847     (goto-char (point-max))
1848     nil)))
1849
1850 (defun article-strip-multiple-blank-lines ()
1851   "Replace consecutive blank lines with one empty line."
1852   (interactive)
1853   (save-excursion
1854     (let ((inhibit-point-motion-hooks t)
1855           buffer-read-only)
1856       ;; First make all blank lines empty.
1857       (article-goto-body)
1858       (while (re-search-forward "^[ \t]+$" nil t)
1859         (unless (gnus-annotation-in-region-p
1860                  (match-beginning 0) (match-end 0))
1861           (replace-match "" nil t)))
1862       ;; Then replace multiple empty lines with a single empty line.
1863       (article-goto-body)
1864       (while (re-search-forward "\n\n\n+" nil t)
1865         (unless (gnus-annotation-in-region-p
1866                  (match-beginning 0) (match-end 0))
1867           (replace-match "\n\n" t t))))))
1868
1869 (defun article-strip-leading-space ()
1870   "Remove all white space from the beginning of the lines in the article."
1871   (interactive)
1872   (save-excursion
1873     (let ((inhibit-point-motion-hooks t)
1874           buffer-read-only)
1875       (article-goto-body)
1876       (while (re-search-forward "^[ \t]+" nil t)
1877         (replace-match "" t t)))))
1878
1879 (defun article-strip-trailing-space ()
1880   "Remove all white space from the end of the lines in the article."
1881   (interactive)
1882   (save-excursion
1883     (let ((inhibit-point-motion-hooks t)
1884           buffer-read-only)
1885       (article-goto-body)
1886       (while (re-search-forward "[ \t]+$" nil t)
1887         (replace-match "" t t)))))
1888
1889 (defun article-strip-blank-lines ()
1890   "Strip leading, trailing and multiple blank lines."
1891   (interactive)
1892   (article-strip-leading-blank-lines)
1893   (article-remove-trailing-blank-lines)
1894   (article-strip-multiple-blank-lines))
1895
1896 (defun article-strip-all-blank-lines ()
1897   "Strip all blank lines."
1898   (interactive)
1899   (save-excursion
1900     (let ((inhibit-point-motion-hooks t)
1901           buffer-read-only)
1902       (article-goto-body)
1903       (while (re-search-forward "^[ \t]*\n" nil t)
1904         (replace-match "" t t)))))
1905
1906 (defun gnus-article-narrow-to-signature ()
1907   "Narrow to the signature; return t if a signature is found, else nil."
1908   (let ((inhibit-point-motion-hooks t))
1909     (when (gnus-article-search-signature)
1910       (forward-line 1)
1911       ;; Check whether we have some limits to what we consider
1912       ;; to be a signature.
1913       (let ((limits (if (listp gnus-signature-limit) gnus-signature-limit
1914                       (list gnus-signature-limit)))
1915             limit limited)
1916         (while (setq limit (pop limits))
1917           (if (or (and (integerp limit)
1918                        (< (- (point-max) (point)) limit))
1919                   (and (floatp limit)
1920                        (< (count-lines (point) (point-max)) limit))
1921                   (and (gnus-functionp limit)
1922                        (funcall limit))
1923                   (and (stringp limit)
1924                        (not (re-search-forward limit nil t))))
1925               ()                        ; This limit did not succeed.
1926             (setq limited t
1927                   limits nil)))
1928         (unless limited
1929           (narrow-to-region (point) (point-max))
1930           t)))))
1931
1932 (defun gnus-article-search-signature ()
1933   "Search the current buffer for the signature separator.
1934 Put point at the beginning of the signature separator."
1935   (let ((cur (point)))
1936     (goto-char (point-max))
1937     (if (if (stringp gnus-signature-separator)
1938             (re-search-backward gnus-signature-separator nil t)
1939           (let ((seps gnus-signature-separator))
1940             (while (and seps
1941                         (not (re-search-backward (car seps) nil t)))
1942               (pop seps))
1943             seps))
1944         t
1945       (goto-char cur)
1946       nil)))
1947
1948 (defun gnus-article-hidden-arg ()
1949   "Return the current prefix arg as a number, or 0 if no prefix."
1950   (list (if current-prefix-arg
1951             (prefix-numeric-value current-prefix-arg)
1952           0)))
1953
1954 (defun gnus-article-check-hidden-text (type arg)
1955   "Return nil if hiding is necessary.
1956 Arg can be nil or a number.  Nil and positive means hide, negative
1957 means show, 0 means toggle."
1958   (save-excursion
1959     (save-restriction
1960       (let ((hide (gnus-article-hidden-text-p type)))
1961         (cond
1962          ((or (null arg)
1963               (> arg 0))
1964           nil)
1965          ((< arg 0)
1966           (gnus-article-show-hidden-text type))
1967          (t
1968           (if (eq hide 'hidden)
1969               (gnus-article-show-hidden-text type)
1970             nil)))))))
1971
1972 (defun gnus-article-hidden-text-p (type)
1973   "Say whether the current buffer contains hidden text of type TYPE."
1974   (let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
1975     (while (and pos
1976                 (not (get-text-property pos 'invisible))
1977                 (not (get-text-property pos 'dummy-invisible)))
1978       (setq pos
1979             (text-property-any (1+ pos) (point-max) 'article-type type)))
1980     (if pos
1981         'hidden
1982       nil)))
1983
1984 (defun gnus-article-show-hidden-text (type &optional hide)
1985   "Show all hidden text of type TYPE.
1986 If HIDE, hide the text instead."
1987   (save-excursion
1988     (let ((buffer-read-only nil)
1989           (inhibit-point-motion-hooks t)
1990           (end (point-min))
1991           beg)
1992       (while (setq beg (text-property-any end (point-max) 'article-type type))
1993         (goto-char beg)
1994         (setq end (or
1995                    (text-property-not-all beg (point-max) 'article-type type)
1996                    (point-max)))
1997         (if hide
1998             (gnus-article-hide-text beg end gnus-hidden-properties)
1999           (gnus-article-unhide-text beg end))
2000         (goto-char end))
2001       t)))
2002
2003 (defconst article-time-units
2004   `((year . ,(* 365.25 24 60 60))
2005     (week . ,(* 7 24 60 60))
2006     (day . ,(* 24 60 60))
2007     (hour . ,(* 60 60))
2008     (minute . 60)
2009     (second . 1))
2010   "Mapping from time units to seconds.")
2011
2012 (defun article-date-ut (&optional type highlight header)
2013   "Convert DATE date to universal time in the current article.
2014 If TYPE is `local', convert to local time; if it is `lapsed', output
2015 how much time has lapsed since DATE.  For `lapsed', the value of
2016 `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
2017 should replace the \"Date:\" one, or should be added below it."
2018   (interactive (list 'ut t))
2019   (let* ((header (or header
2020                      (and (eq 1 (point-min))
2021                           (mail-header-date (save-excursion
2022                                               (set-buffer gnus-summary-buffer)
2023                                               gnus-current-headers)))
2024                      (message-fetch-field "date")
2025                      ""))
2026          (date (if (vectorp header) (mail-header-date header)
2027                  header))
2028          (inhibit-point-motion-hooks t)
2029          bface eface date-pos)
2030     (when (and date (not (string= date "")))
2031       (save-excursion
2032         (save-restriction
2033           (article-narrow-to-head)
2034           (when (or (and (eq type 'lapsed)
2035                          gnus-article-date-lapsed-new-header
2036                          ;; Attempt to get the face of X-Sent first.
2037                          (re-search-forward "^X-Sent:[ \t]" nil t))
2038                     (re-search-forward "^Date:[ \t]" nil t)
2039                     ;; If Date is missing, try again for X-Sent.
2040                     (re-search-forward "^X-Sent:[ \t]" nil t))
2041             (setq bface (get-text-property (gnus-point-at-bol) 'face)
2042                   date (or (get-text-property (gnus-point-at-bol)
2043                                                 'original-date)
2044                              date)
2045                   eface (get-text-property (1- (gnus-point-at-eol))
2046                                            'face)))
2047           (let ((buffer-read-only nil))
2048             ;; Delete any old X-Sent headers.
2049             (when (setq date-pos
2050                         (text-property-any (point-min) (point-max)
2051                                            'article-date-lapsed t))
2052               (goto-char (setq date-pos (set-marker (make-marker) date-pos)))
2053               (delete-region (match-beginning 0)
2054                              (progn (forward-line 1) (point))))
2055             (goto-char (point-min))
2056             ;; Delete any old Date headers.
2057             (while (re-search-forward "^Date:[ \t]" nil t)
2058               (unless date-pos
2059                 (setq date-pos (match-beginning 0)))
2060               (unless (and (eq type 'lapsed)
2061                            gnus-article-date-lapsed-new-header)
2062                 (delete-region (match-beginning 0)
2063                                (progn (message-next-header) (point)))))
2064             (if date-pos
2065                 (progn
2066                   (goto-char date-pos)
2067                   (unless (bolp)
2068                     ;; Possibly, Date has been deleted.
2069                     (insert "\n"))
2070                   (when (and (eq type 'lapsed)
2071                              gnus-article-date-lapsed-new-header
2072                              (looking-at "Date:"))
2073                     (forward-line 1)))
2074               (goto-char (point-min)))
2075             (insert (article-make-date-line date type))
2076             (when (eq type 'lapsed)
2077               (put-text-property (gnus-point-at-bol) (point)
2078                                  'article-date-lapsed t))
2079             (insert "\n")
2080             (forward-line -1)
2081             ;; Do highlighting.
2082             (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
2083               (put-text-property (match-beginning 1) (1+ (match-end 1))
2084                                  'original-date date)
2085               (put-text-property (match-beginning 1) (1+ (match-end 1))
2086                                  'face bface)
2087               (put-text-property (match-beginning 2) (match-end 2)
2088                                  'face eface))))))))
2089
2090 (defun article-make-date-line (date type)
2091   "Return a DATE line of TYPE."
2092   (let ((time (condition-case ()
2093                   (date-to-time date)
2094                 (error '(0 0)))))
2095     (cond
2096      ;; Convert to the local timezone.  We have to slap a
2097      ;; `condition-case' round the calls to the timezone
2098      ;; functions since they aren't particularly resistant to
2099      ;; buggy dates.
2100      ((eq type 'local)
2101       (let ((tz (car (current-time-zone time))))
2102         (format "Date: %s %s%02d%02d" (current-time-string time)
2103                 (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2104                 (/ (% (abs tz) 3600) 60))))
2105      ;; Convert to Universal Time.
2106      ((eq type 'ut)
2107       (concat "Date: "
2108               (current-time-string
2109                (let* ((e (parse-time-string date))
2110                       (tm (apply 'encode-time e))
2111                       (ms (car tm))
2112                       (ls (- (cadr tm) (car (current-time-zone time)))))
2113                  (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
2114                        ((> ls 65535) (list (1+ ms) (- ls 65536)))
2115                        (t (list ms ls)))))
2116               " UT"))
2117      ;; Get the original date from the article.
2118      ((eq type 'original)
2119       (concat "Date: " (if (string-match "\n+$" date)
2120                            (substring date 0 (match-beginning 0))
2121                          date)))
2122      ;; Let the user define the format.
2123      ((eq type 'user)
2124       (if (gnus-functionp gnus-article-time-format)
2125           (funcall gnus-article-time-format time)
2126         (concat
2127          "Date: "
2128          (format-time-string gnus-article-time-format time))))
2129      ;; ISO 8601.
2130      ((eq type 'iso8601)
2131       (let ((tz (car (current-time-zone time))))
2132         (concat
2133          "Date: "
2134          (format-time-string "%Y%m%dT%H%M%S" time)
2135          (format "%s%02d%02d"
2136                  (if (> tz 0) "+" "-") (/ (abs tz) 3600)
2137                  (/ (% (abs tz) 3600) 60)))))
2138      ;; Do an X-Sent lapsed format.
2139      ((eq type 'lapsed)
2140       ;; If the date is seriously mangled, the timezone functions are
2141       ;; liable to bug out, so we ignore all errors.
2142       (let* ((now (current-time))
2143              (real-time (subtract-time now time))
2144              (real-sec (and real-time
2145                             (+ (* (float (car real-time)) 65536)
2146                                (cadr real-time))))
2147              (sec (and real-time (abs real-sec)))
2148              num prev)
2149         (cond
2150          ((null real-time)
2151           "X-Sent: Unknown")
2152          ((zerop sec)
2153           "X-Sent: Now")
2154          (t
2155           (concat
2156            "X-Sent: "
2157            ;; This is a bit convoluted, but basically we go
2158            ;; through the time units for years, weeks, etc,
2159            ;; and divide things to see whether that results
2160            ;; in positive answers.
2161            (mapconcat
2162             (lambda (unit)
2163               (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
2164                   ;; The (remaining) seconds are too few to
2165                   ;; be divided into this time unit.
2166                   ""
2167                 ;; It's big enough, so we output it.
2168                 (setq sec (- sec (* num (cdr unit))))
2169                 (prog1
2170                     (concat (if prev ", " "") (int-to-string
2171                                                (floor num))
2172                             " " (symbol-name (car unit))
2173                             (if (> num 1) "s" ""))
2174                   (setq prev t))))
2175             article-time-units "")
2176            ;; If dates are odd, then it might appear like the
2177            ;; article was sent in the future.
2178            (if (> real-sec 0)
2179                " ago"
2180              " in the future"))))))
2181      (t
2182       (error "Unknown conversion type: %s" type)))))
2183
2184 (defun article-date-local (&optional highlight)
2185   "Convert the current article date to the local timezone."
2186   (interactive (list t))
2187   (article-date-ut 'local highlight))
2188
2189 (defun article-date-original (&optional highlight)
2190   "Convert the current article date to what it was originally.
2191 This is only useful if you have used some other date conversion
2192 function and want to see what the date was before converting."
2193   (interactive (list t))
2194   (article-date-ut 'original highlight))
2195
2196 (defun article-date-lapsed (&optional highlight)
2197   "Convert the current article date to time lapsed since it was sent."
2198   (interactive (list t))
2199   (article-date-ut 'lapsed highlight))
2200
2201 (defun article-update-date-lapsed ()
2202   "Function to be run from a timer to update the lapsed time line."
2203   (let (deactivate-mark)
2204     (save-excursion
2205       (ignore-errors
2206         (walk-windows
2207          (lambda (w)
2208            (set-buffer (window-buffer w))
2209            (when (eq major-mode 'gnus-article-mode)
2210              (goto-char (point-min))
2211              (when (re-search-forward "^X-Sent:" nil t)
2212                (article-date-lapsed t))))
2213          nil 'visible)))))
2214
2215 (defun gnus-start-date-timer (&optional n)
2216   "Start a timer to update the X-Sent header in the article buffers.
2217 The numerical prefix says how frequently (in seconds) the function
2218 is to run."
2219   (interactive "p")
2220   (unless n
2221     (setq n 1))
2222   (gnus-stop-date-timer)
2223   (setq article-lapsed-timer
2224         (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
2225
2226 (defun gnus-stop-date-timer ()
2227   "Stop the X-Sent timer."
2228   (interactive)
2229   (when article-lapsed-timer
2230     (nnheader-cancel-timer article-lapsed-timer)
2231     (setq article-lapsed-timer nil)))
2232
2233 (defun article-date-user (&optional highlight)
2234   "Convert the current article date to the user-defined format.
2235 This format is defined by the `gnus-article-time-format' variable."
2236   (interactive (list t))
2237   (article-date-ut 'user highlight))
2238
2239 (defun article-date-iso8601 (&optional highlight)
2240   "Convert the current article date to ISO8601."
2241   (interactive (list t))
2242   (article-date-ut 'iso8601 highlight))
2243
2244 (defun article-show-all ()
2245   "Show all hidden text in the article buffer."
2246   (interactive)
2247   (save-excursion
2248     (widen)
2249     (let ((buffer-read-only nil))
2250       (gnus-article-unhide-text (point-min) (point-max))
2251       (gnus-remove-text-with-property 'gnus-prev)
2252       (gnus-remove-text-with-property 'gnus-next))))
2253
2254 (defun article-show-all-headers ()
2255   "Show all hidden headers in the article buffer."
2256   (interactive)
2257   (save-excursion
2258     (save-restriction
2259       (widen)
2260       (article-narrow-to-head)
2261       (let ((buffer-read-only nil))
2262         (gnus-article-unhide-text (point-min) (point-max))))))
2263
2264 (defun article-emphasize (&optional arg)
2265   "Emphasize text according to `gnus-emphasis-alist'."
2266   (interactive (gnus-article-hidden-arg))
2267   (unless (gnus-article-check-hidden-text 'emphasis arg)
2268     (save-excursion
2269       (let ((alist (or
2270                     (condition-case nil
2271                         (with-current-buffer gnus-summary-buffer
2272                           gnus-article-emphasis-alist)
2273                       (error))
2274                     gnus-emphasis-alist))
2275             (buffer-read-only nil)
2276             (props (append '(article-type emphasis)
2277                            gnus-hidden-properties))
2278             regexp elem beg invisible visible face)
2279         (article-goto-body)
2280         (setq beg (point))
2281         (while (setq elem (pop alist))
2282           (goto-char beg)
2283           (setq regexp (car elem)
2284                 invisible (nth 1 elem)
2285                 visible (nth 2 elem)
2286                 face (nth 3 elem))
2287           (while (re-search-forward regexp nil t)
2288             (when (and (match-beginning visible) (match-beginning invisible))
2289               (push 'emphasis gnus-article-wash-types)
2290               (gnus-article-hide-text
2291                (match-beginning invisible) (match-end invisible) props)
2292               (gnus-article-unhide-text-type
2293                (match-beginning visible) (match-end visible) 'emphasis)
2294               (gnus-put-text-property-excluding-newlines
2295                (match-beginning visible) (match-end visible) 'face face)
2296               (goto-char (match-end invisible)))))))))
2297
2298 (defun gnus-article-setup-highlight-words (&optional highlight-words)
2299   "Setup newsgroup emphasis alist."
2300   (unless gnus-article-emphasis-alist
2301     (let ((name (and gnus-newsgroup-name
2302                      (gnus-group-real-name gnus-newsgroup-name))))
2303       (make-local-variable 'gnus-article-emphasis-alist)
2304       (setq gnus-article-emphasis-alist
2305             (nconc
2306              (let ((alist gnus-group-highlight-words-alist) elem highlight)
2307                (while (setq elem (pop alist))
2308                  (when (and name (string-match (car elem) name))
2309                    (setq alist nil
2310                          highlight (copy-sequence (cdr elem)))))
2311                highlight)
2312              (copy-sequence highlight-words)
2313              (if gnus-newsgroup-name
2314                  (copy-sequence (gnus-group-find-parameter
2315                                  gnus-newsgroup-name 'highlight-words t)))
2316              gnus-emphasis-alist)))))
2317
2318 (defvar gnus-summary-article-menu)
2319 (defvar gnus-summary-post-menu)
2320
2321 ;;; Saving functions.
2322
2323 (defun gnus-article-save (save-buffer file &optional num)
2324   "Save the currently selected article."
2325   (unless gnus-save-all-headers
2326     ;; Remove headers according to `gnus-saved-headers'.
2327     (let ((gnus-visible-headers
2328            (or gnus-saved-headers gnus-visible-headers))
2329           (gnus-article-buffer save-buffer))
2330       (save-excursion
2331         (set-buffer save-buffer)
2332         (article-hide-headers 1 t))))
2333   (save-window-excursion
2334     (if (not gnus-default-article-saver)
2335         (error "No default saver is defined")
2336       ;; !!! Magic!  The saving functions all save
2337       ;; `gnus-save-article-buffer' (or so they think), but we
2338       ;; bind that variable to our save-buffer.
2339       (set-buffer gnus-article-buffer)
2340       (let* ((gnus-save-article-buffer save-buffer)
2341              (filename
2342               (cond
2343                ((not gnus-prompt-before-saving) 'default)
2344                ((eq gnus-prompt-before-saving 'always) nil)
2345                (t file)))
2346              (gnus-number-of-articles-to-be-saved
2347               (when (eq gnus-prompt-before-saving t)
2348                 num)))                  ; Magic
2349         (set-buffer gnus-article-current-summary)
2350         (funcall gnus-default-article-saver filename)))))
2351
2352 (defun gnus-read-save-file-name (prompt &optional filename
2353                                         function group headers variable)
2354   (let ((default-name
2355           (funcall function group headers (symbol-value variable)))
2356         result)
2357     (setq
2358      result
2359      (cond
2360       ((eq filename 'default)
2361        default-name)
2362       ((eq filename t)
2363        default-name)
2364       (filename filename)
2365       (t
2366        (let* ((split-name (gnus-get-split-value gnus-split-methods))
2367               (prompt
2368                (format prompt
2369                        (if (and gnus-number-of-articles-to-be-saved
2370                                 (> gnus-number-of-articles-to-be-saved 1))
2371                            (format "these %d articles"
2372                                    gnus-number-of-articles-to-be-saved)
2373                          "this article")))
2374               (file
2375                ;; Let the split methods have their say.
2376                (cond
2377                 ;; No split name was found.
2378                 ((null split-name)
2379                  (read-file-name
2380                   (concat prompt " (default "
2381                           (file-name-nondirectory default-name) ") ")
2382                   (file-name-directory default-name)
2383                   default-name))
2384                 ;; A single group name is returned.
2385                 ((stringp split-name)
2386                  (setq default-name
2387                        (funcall function split-name headers
2388                                 (symbol-value variable)))
2389                  (read-file-name
2390                   (concat prompt " (default "
2391                           (file-name-nondirectory default-name) ") ")
2392                   (file-name-directory default-name)
2393                   default-name))
2394                 ;; A single split name was found
2395                 ((= 1 (length split-name))
2396                  (let* ((name (expand-file-name
2397                                (car split-name) gnus-article-save-directory))
2398                         (dir (cond ((file-directory-p name)
2399                                     (file-name-as-directory name))
2400                                    ((file-exists-p name) name)
2401                                    (t gnus-article-save-directory))))
2402                    (read-file-name
2403                     (concat prompt " (default " name ") ")
2404                     dir name)))
2405                 ;; A list of splits was found.
2406                 (t
2407                  (setq split-name (nreverse split-name))
2408                  (let (result)
2409                    (let ((file-name-history
2410                           (nconc split-name file-name-history)))
2411                      (setq result
2412                            (expand-file-name
2413                             (read-file-name
2414                              (concat prompt " (`M-p' for defaults) ")
2415                              gnus-article-save-directory
2416                              (car split-name))
2417                             gnus-article-save-directory)))
2418                    (car (push result file-name-history)))))))
2419          ;; Create the directory.
2420          (gnus-make-directory (file-name-directory file))
2421          ;; If we have read a directory, we append the default file name.
2422          (when (file-directory-p file)
2423            (setq file (concat (file-name-as-directory file)
2424                               (file-name-nondirectory default-name))))
2425          ;; Possibly translate some characters.
2426          (nnheader-translate-file-chars file)))))
2427     (gnus-make-directory (file-name-directory result))
2428     (set variable result)))
2429
2430 (defun gnus-article-archive-name (group)
2431   "Return the first instance of an \"Archive-name\" in the current buffer."
2432   (let ((case-fold-search t))
2433     (when (re-search-forward "archive-name: *\\([^ \n\t]+\\)[ \t]*$" nil t)
2434       (nnheader-concat gnus-article-save-directory
2435                        (match-string 1)))))
2436
2437 (defun gnus-article-nndoc-name (group)
2438   "If GROUP is an nndoc group, return the name of the parent group."
2439   (when (eq (car (gnus-find-method-for-group group)) 'nndoc)
2440     (gnus-group-get-parameter group 'save-article-group)))
2441
2442 (defun gnus-summary-save-in-rmail (&optional filename)
2443   "Append this article to Rmail file.
2444 Optional argument FILENAME specifies file name.
2445 Directory to save to is default to `gnus-article-save-directory'."
2446   (setq filename (gnus-read-save-file-name
2447                   "Save %s in rmail file:" filename
2448                   gnus-rmail-save-name gnus-newsgroup-name
2449                   gnus-current-headers 'gnus-newsgroup-last-rmail))
2450   (gnus-eval-in-buffer-window gnus-save-article-buffer
2451     (save-excursion
2452       (save-restriction
2453         (widen)
2454         (gnus-output-to-rmail filename))))
2455   filename)
2456
2457 (defun gnus-summary-save-in-mail (&optional filename)
2458   "Append this article to Unix mail file.
2459 Optional argument FILENAME specifies file name.
2460 Directory to save to is default to `gnus-article-save-directory'."
2461   (setq filename (gnus-read-save-file-name
2462                   "Save %s in Unix mail file:" filename
2463                   gnus-mail-save-name gnus-newsgroup-name
2464                   gnus-current-headers 'gnus-newsgroup-last-mail))
2465   (gnus-eval-in-buffer-window gnus-save-article-buffer
2466     (save-excursion
2467       (save-restriction
2468         (widen)
2469         (if (and (file-readable-p filename)
2470                  (mail-file-babyl-p filename))
2471             (rmail-output-to-rmail-file filename t)
2472           (gnus-output-to-mail filename)))))
2473   filename)
2474
2475 (defun gnus-summary-save-in-file (&optional filename overwrite)
2476   "Append this article to file.
2477 Optional argument FILENAME specifies file name.
2478 Directory to save to is default to `gnus-article-save-directory'."
2479   (setq filename (gnus-read-save-file-name
2480                   "Save %s in file:" filename
2481                   gnus-file-save-name gnus-newsgroup-name
2482                   gnus-current-headers 'gnus-newsgroup-last-file))
2483   (gnus-eval-in-buffer-window gnus-save-article-buffer
2484     (save-excursion
2485       (save-restriction
2486         (widen)
2487         (when (and overwrite
2488                    (file-exists-p filename))
2489           (delete-file filename))
2490         (gnus-output-to-file filename))))
2491   filename)
2492
2493 (defun gnus-summary-write-to-file (&optional filename)
2494   "Write this article to a file.
2495 Optional argument FILENAME specifies file name.
2496 The directory to save in defaults to `gnus-article-save-directory'."
2497   (gnus-summary-save-in-file nil t))
2498
2499 (defun gnus-summary-save-body-in-file (&optional filename)
2500   "Append this article body to a file.
2501 Optional argument FILENAME specifies file name.
2502 The directory to save in defaults to `gnus-article-save-directory'."
2503   (setq filename (gnus-read-save-file-name
2504                   "Save %s body in file:" filename
2505                   gnus-file-save-name gnus-newsgroup-name
2506                   gnus-current-headers 'gnus-newsgroup-last-file))
2507   (gnus-eval-in-buffer-window gnus-save-article-buffer
2508     (save-excursion
2509       (save-restriction
2510         (widen)
2511         (when (article-goto-body)
2512           (narrow-to-region (point) (point-max)))
2513         (gnus-output-to-file filename))))
2514   filename)
2515
2516 (defun gnus-summary-save-in-pipe (&optional command)
2517   "Pipe this article to subprocess."
2518   (setq command
2519         (cond ((and (eq command 'default)
2520                     gnus-last-shell-command)
2521                gnus-last-shell-command)
2522               (command command)
2523               (t (read-string
2524                   (format
2525                    "Shell command on %s: "
2526                    (if (and gnus-number-of-articles-to-be-saved
2527                             (> gnus-number-of-articles-to-be-saved 1))
2528                        (format "these %d articles"
2529                                gnus-number-of-articles-to-be-saved)
2530                      "this article"))
2531                   gnus-last-shell-command))))
2532   (when (string-equal command "")
2533     (setq command gnus-last-shell-command))
2534   (gnus-eval-in-buffer-window gnus-article-buffer
2535     (save-restriction
2536       (widen)
2537       (shell-command-on-region (point-min) (point-max) command nil)))
2538   (setq gnus-last-shell-command command))
2539
2540 ;;; Article file names when saving.
2541
2542 (defun gnus-capitalize-newsgroup (newsgroup)
2543   "Capitalize NEWSGROUP name."
2544   (when (not (zerop (length newsgroup)))
2545     (concat (char-to-string (upcase (aref newsgroup 0)))
2546             (substring newsgroup 1))))
2547
2548 (defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
2549   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2550 If variable `gnus-use-long-file-name' is non-nil, it is ~/News/News.group/num.
2551 Otherwise, it is like ~/News/news/group/num."
2552   (let ((default
2553           (expand-file-name
2554            (concat (if (gnus-use-long-file-name 'not-save)
2555                        (gnus-capitalize-newsgroup newsgroup)
2556                      (gnus-newsgroup-directory-form newsgroup))
2557                    "/" (int-to-string (mail-header-number headers)))
2558            gnus-article-save-directory)))
2559     (if (and last-file
2560              (string-equal (file-name-directory default)
2561                            (file-name-directory last-file))
2562              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2563         default
2564       (or last-file default))))
2565
2566 (defun gnus-numeric-save-name (newsgroup headers &optional last-file)
2567   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2568 If variable `gnus-use-long-file-name' is non-nil, it is
2569 ~/News/news.group/num.  Otherwise, it is like ~/News/news/group/num."
2570   (let ((default
2571           (expand-file-name
2572            (concat (if (gnus-use-long-file-name 'not-save)
2573                        newsgroup
2574                      (gnus-newsgroup-directory-form newsgroup))
2575                    "/" (int-to-string (mail-header-number headers)))
2576            gnus-article-save-directory)))
2577     (if (and last-file
2578              (string-equal (file-name-directory default)
2579                            (file-name-directory last-file))
2580              (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
2581         default
2582       (or last-file default))))
2583
2584 (defun gnus-Plain-save-name (newsgroup headers &optional last-file)
2585   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2586 If variable `gnus-use-long-file-name' is non-nil, it is
2587 ~/News/News.group.  Otherwise, it is like ~/News/news/group/news."
2588   (or last-file
2589       (expand-file-name
2590        (if (gnus-use-long-file-name 'not-save)
2591            (gnus-capitalize-newsgroup newsgroup)
2592          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2593        gnus-article-save-directory)))
2594
2595 (defun gnus-plain-save-name (newsgroup headers &optional last-file)
2596   "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
2597 If variable `gnus-use-long-file-name' is non-nil, it is
2598 ~/News/news.group.  Otherwise, it is like ~/News/news/group/news."
2599   (or last-file
2600       (expand-file-name
2601        (if (gnus-use-long-file-name 'not-save)
2602            newsgroup
2603          (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
2604        gnus-article-save-directory)))
2605
2606 (eval-and-compile
2607   (mapcar
2608    (lambda (func)
2609      (let (afunc gfunc)
2610        (if (consp func)
2611            (setq afunc (car func)
2612                  gfunc (cdr func))
2613          (setq afunc func
2614                gfunc (intern (format "gnus-%s" func))))
2615        (fset gfunc
2616              (if (not (fboundp afunc))
2617                  nil
2618                `(lambda (&optional interactive &rest args)
2619                   ,(documentation afunc t)
2620                   (interactive (list t))
2621                   (save-excursion
2622                     (set-buffer gnus-article-buffer)
2623                     (if interactive
2624                         (call-interactively ',afunc)
2625                       (apply ',afunc args))))))))
2626    '(article-hide-headers
2627      article-hide-boring-headers
2628      article-toggle-headers
2629      article-treat-overstrike
2630      article-fill-long-lines
2631      article-capitalize-sentences
2632      article-remove-cr
2633      article-display-x-face
2634      article-de-quoted-unreadable
2635      article-decode-HZ
2636      article-hide-list-identifiers
2637      article-hide-pgp
2638      article-strip-banner
2639      article-babel
2640      article-hide-pem
2641      article-hide-signature
2642      article-strip-headers-in-body
2643      article-remove-trailing-blank-lines
2644      article-strip-leading-blank-lines
2645      article-strip-multiple-blank-lines
2646      article-strip-leading-space
2647      article-strip-trailing-space
2648      article-strip-blank-lines
2649      article-strip-all-blank-lines
2650      article-date-local
2651      article-date-iso8601
2652      article-date-original
2653      article-date-ut
2654      article-decode-mime-words
2655      article-decode-charset
2656      article-decode-encoded-words
2657      article-date-user
2658      article-date-lapsed
2659      article-emphasize
2660      article-treat-dumbquotes
2661      article-normalize-headers
2662      (article-show-all-headers . gnus-article-show-all-headers)
2663      (article-show-all . gnus-article-show-all))))
2664 \f
2665 ;;;
2666 ;;; Gnus article mode
2667 ;;;
2668
2669 (put 'gnus-article-mode 'mode-class 'special)
2670
2671 (gnus-define-keys gnus-article-mode-map
2672   " " gnus-article-goto-next-page
2673   "\177" gnus-article-goto-prev-page
2674   [delete] gnus-article-goto-prev-page
2675   [backspace] gnus-article-goto-prev-page
2676   "\C-c^" gnus-article-refer-article
2677   "h" gnus-article-show-summary
2678   "s" gnus-article-show-summary
2679   "\C-c\C-m" gnus-article-mail
2680   "?" gnus-article-describe-briefly
2681   "e" gnus-summary-edit-article
2682   "<" beginning-of-buffer
2683   ">" end-of-buffer
2684   "\C-c\C-i" gnus-info-find-node
2685   "\C-c\C-b" gnus-bug
2686
2687   "\C-d" gnus-article-read-summary-keys
2688   "\M-*" gnus-article-read-summary-keys
2689   "\M-#" gnus-article-read-summary-keys
2690   "\M-^" gnus-article-read-summary-keys
2691   "\M-g" gnus-article-read-summary-keys)
2692
2693 ;; Define almost undefined keys to `gnus-article-read-summary-keys'.
2694 (mapcar
2695  (lambda (key)
2696    (unless (lookup-key gnus-article-mode-map key)
2697      (define-key gnus-article-mode-map key
2698        'gnus-article-read-summary-keys)))
2699  (delq nil
2700        (append
2701         (mapcar
2702          (lambda (elt)
2703            (let ((key (car elt)))
2704              (and (> (length key) 0)
2705                   (not (eq 'menu-bar (aref key 0)))
2706                   (symbolp (lookup-key gnus-summary-mode-map key))
2707                   key)))
2708          (accessible-keymaps gnus-summary-mode-map))
2709         (let ((c 127)
2710               keys)
2711           (while (>= c 32)
2712             (push (char-to-string c) keys)
2713             (decf c))
2714           keys))))
2715
2716 (defun gnus-article-make-menu-bar ()
2717   (gnus-turn-off-edit-menu 'article)
2718   (unless (boundp 'gnus-article-article-menu)
2719     (easy-menu-define
2720      gnus-article-article-menu gnus-article-mode-map ""
2721      '("Article"
2722        ["Scroll forwards" gnus-article-goto-next-page t]
2723        ["Scroll backwards" gnus-article-goto-prev-page t]
2724        ["Show summary" gnus-article-show-summary t]
2725        ["Fetch Message-ID at point" gnus-article-refer-article t]
2726        ["Mail to address at point" gnus-article-mail t]
2727        ["Send a bug report" gnus-bug t]))
2728
2729     (easy-menu-define
2730      gnus-article-treatment-menu gnus-article-mode-map ""
2731      '("Treatment"
2732        ["Hide headers" gnus-article-toggle-headers t]
2733        ["Hide signature" gnus-article-hide-signature t]
2734        ["Hide citation" gnus-article-hide-citation t]
2735        ["Treat overstrike" gnus-article-treat-overstrike t]
2736        ["Remove carriage return" gnus-article-remove-cr t]
2737        ["Decode HZ" gnus-article-decode-HZ t]))
2738
2739     ;; Note "Commands" menu is defined in gnus-sum.el for consistency
2740
2741     (when (boundp 'gnus-summary-post-menu)
2742       (define-key gnus-article-mode-map [menu-bar post]
2743         (cons "Post" gnus-summary-post-menu)))
2744
2745     (gnus-run-hooks 'gnus-article-menu-hook)))
2746
2747 (defun gnus-article-mode ()
2748   "Major mode for displaying an article.
2749
2750 All normal editing commands are switched off.
2751
2752 The following commands are available in addition to all summary mode
2753 commands:
2754 \\<gnus-article-mode-map>
2755 \\[gnus-article-next-page]\t Scroll the article one page forwards
2756 \\[gnus-article-prev-page]\t Scroll the article one page backwards
2757 \\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
2758 \\[gnus-article-show-summary]\t Display the summary buffer
2759 \\[gnus-article-mail]\t Send a reply to the address near point
2760 \\[gnus-article-describe-briefly]\t Describe the current mode briefly
2761 \\[gnus-info-find-node]\t Go to the Gnus info node"
2762   (interactive)
2763   (when (gnus-visual-p 'article-menu 'menu)
2764     (gnus-article-make-menu-bar))
2765   (gnus-simplify-mode-line)
2766   (setq mode-name "Article")
2767   (setq major-mode 'gnus-article-mode)
2768   (make-local-variable 'minor-mode-alist)
2769   (unless (assq 'gnus-show-mime minor-mode-alist)
2770     (push (list 'gnus-show-mime " MIME") minor-mode-alist))
2771   (use-local-map gnus-article-mode-map)
2772   (gnus-update-format-specifications nil 'article-mode)
2773   (set (make-local-variable 'page-delimiter) gnus-page-delimiter)
2774   (make-local-variable 'gnus-page-broken)
2775   (make-local-variable 'gnus-button-marker-list)
2776   (make-local-variable 'gnus-article-current-summary)
2777   (make-local-variable 'gnus-article-mime-handles)
2778   (make-local-variable 'gnus-article-decoded-p)
2779   (make-local-variable 'gnus-article-mime-handle-alist)
2780   (make-local-variable 'gnus-article-wash-types)
2781   (gnus-set-default-directory)
2782   (buffer-disable-undo)
2783   (setq buffer-read-only t)
2784   (set-syntax-table gnus-article-mode-syntax-table)
2785   (gnus-run-hooks 'gnus-article-mode-hook))
2786
2787 (defun gnus-article-setup-buffer ()
2788   "Initialize the article buffer."
2789   (let* ((name (if gnus-single-article-buffer "*Article*"
2790                  (concat "*Article " gnus-newsgroup-name "*")))
2791          (original
2792           (progn (string-match "\\*Article" name)
2793                  (concat " *Original Article"
2794                          (substring name (match-end 0))))))
2795     (setq gnus-article-buffer name)
2796     (setq gnus-original-article-buffer original)
2797     (setq gnus-article-mime-handle-alist nil)
2798     ;; This might be a variable local to the summary buffer.
2799     (unless gnus-single-article-buffer
2800       (save-excursion
2801         (set-buffer gnus-summary-buffer)
2802         (setq gnus-article-buffer name)
2803         (setq gnus-original-article-buffer original)
2804         (gnus-set-global-variables)))
2805     (gnus-article-setup-highlight-words)
2806     ;; Init original article buffer.
2807     (save-excursion
2808       (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
2809       (setq major-mode 'gnus-original-article-mode)
2810       (make-local-variable 'gnus-original-article))
2811     (if (get-buffer name)
2812         (save-excursion
2813           (set-buffer name)
2814           (buffer-disable-undo)
2815           (setq buffer-read-only t)
2816           (unless (eq major-mode 'gnus-article-mode)
2817             (gnus-article-mode))
2818           (current-buffer))
2819       (save-excursion
2820         (set-buffer (gnus-get-buffer-create name))
2821         (gnus-article-mode)
2822         (make-local-variable 'gnus-summary-buffer)
2823         (gnus-summary-set-local-parameters gnus-newsgroup-name)
2824         (current-buffer)))))
2825
2826 ;; Set article window start at LINE, where LINE is the number of lines
2827 ;; from the head of the article.
2828 (defun gnus-article-set-window-start (&optional line)
2829   (set-window-start
2830    (get-buffer-window gnus-article-buffer t)
2831    (save-excursion
2832      (set-buffer gnus-article-buffer)
2833      (goto-char (point-min))
2834      (if (not line)
2835          (point-min)
2836        (gnus-message 6 "Moved to bookmark")
2837        (search-forward "\n\n" nil t)
2838        (forward-line line)
2839        (point)))))
2840
2841 ;;; @@ article filters
2842 ;;;
2843
2844 (defun gnus-article-display-mime-message ()
2845   "Article display method for MIME message."
2846   ;; called from `gnus-original-article-buffer'.
2847   (let (charset all-headers)
2848     (with-current-buffer gnus-summary-buffer
2849       (setq charset default-mime-charset
2850             all-headers gnus-have-all-headers))
2851     (make-local-variable 'default-mime-charset)
2852     (setq default-mime-charset charset)
2853     (with-current-buffer (get-buffer-create gnus-article-buffer)
2854       (make-local-variable 'default-mime-charset)
2855       (setq default-mime-charset charset))
2856     (mime-display-message mime-message-structure
2857                           gnus-article-buffer nil gnus-article-mode-map)
2858     (when all-headers
2859       (gnus-article-hide-headers nil -1))
2860     )
2861   ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
2862   (make-local-variable 'mime-button-mother-dispatcher)
2863   (setq mime-button-mother-dispatcher
2864         (function gnus-article-push-button))
2865   (run-hooks 'gnus-mime-article-prepare-hook))
2866
2867 (defun gnus-article-display-traditional-message ()
2868   "Article display method for traditional message."
2869   (set-buffer gnus-article-buffer)
2870   (let (buffer-read-only)
2871     (erase-buffer)
2872     (insert-buffer-substring gnus-original-article-buffer)))
2873
2874 (defun gnus-article-make-full-mail-header (&optional number charset)
2875   "Create a new mail header structure in a raw article buffer."
2876   (unless (and number charset)
2877     (save-current-buffer
2878       (set-buffer gnus-summary-buffer)
2879       (unless number
2880         (setq number (or (cdr gnus-article-current) 0)))
2881       (unless charset
2882         (setq charset (or default-mime-charset 'x-ctext)))))
2883   (goto-char (point-min))
2884   (let ((header-end (if (search-forward "\n\n" nil t)
2885                         (1- (point))
2886                       (goto-char (point-max))))
2887         (chars (- (point-max) (point)))
2888         (lines (count-lines (point) (point-max)))
2889         (default-mime-charset charset)
2890         xref)
2891     (narrow-to-region (point-min) header-end)
2892     (setq xref (std11-fetch-field "xref"))
2893     (prog1
2894         (make-full-mail-header
2895          number
2896          (std11-fetch-field "subject")
2897          (std11-fetch-field "from")
2898          (std11-fetch-field "date")
2899          (std11-fetch-field "message-id")
2900          (std11-fetch-field "references")
2901          chars
2902          lines
2903          (when xref (concat "Xref: " xref)))
2904       (widen))))
2905
2906 (defun gnus-article-prepare (article &optional all-headers header)
2907   "Prepare ARTICLE in article mode buffer.
2908 ARTICLE should either be an article number or a Message-ID.
2909 If ARTICLE is an id, HEADER should be the article headers.
2910 If ALL-HEADERS is non-nil, no headers are hidden."
2911   (save-excursion
2912     ;; Make sure we start in a summary buffer.
2913     (unless (eq major-mode 'gnus-summary-mode)
2914       (set-buffer gnus-summary-buffer))
2915     (setq gnus-summary-buffer (current-buffer))
2916     (let* ((gnus-article (if header (mail-header-number header) article))
2917            (summary-buffer (current-buffer))
2918            (gnus-tmp-internal-hook gnus-article-internal-prepare-hook)
2919            (group gnus-newsgroup-name)
2920            result)
2921       (save-excursion
2922         (gnus-article-setup-buffer)
2923         (set-buffer gnus-original-article-buffer)
2924         ;; Deactivate active regions.
2925         (when (and (boundp 'transient-mark-mode)
2926                    transient-mark-mode)
2927           (setq mark-active nil))
2928         (if (not (setq result (let ((buffer-read-only nil))
2929                                 (gnus-request-article-this-buffer
2930                                  article group))))
2931             ;; There is no such article.
2932             (save-excursion
2933               (when (and (numberp article)
2934                          (not (memq article gnus-newsgroup-sparse)))
2935                 (setq gnus-article-current
2936                       (cons gnus-newsgroup-name article))
2937                 (set-buffer gnus-summary-buffer)
2938                 (setq gnus-current-article article)
2939                 (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
2940                     (progn
2941                       (gnus-summary-set-agent-mark article)
2942                       (message "Message marked for downloading"))
2943                   (gnus-summary-mark-article article gnus-canceled-mark)
2944                   (unless (memq article gnus-newsgroup-sparse)
2945                     (gnus-error 1 "No such article (may have expired or been canceled)")))))
2946           (if (or (eq result 'pseudo)
2947                   (eq result 'nneething))
2948               (progn
2949                 (save-excursion
2950                   (set-buffer summary-buffer)
2951                   (push article gnus-newsgroup-history)
2952                   (setq gnus-last-article gnus-current-article
2953                         gnus-current-article 0
2954                         gnus-current-headers nil
2955                         gnus-article-current nil)
2956                   (if (eq result 'nneething)
2957                       (gnus-configure-windows 'summary)
2958                     (gnus-configure-windows 'article))
2959                   (gnus-set-global-variables))
2960                 (let ((gnus-article-mime-handle-alist-1
2961                        gnus-article-mime-handle-alist))
2962                   (gnus-set-mode-line 'article)))
2963             ;; The result from the `request' was an actual article -
2964             ;; or at least some text that is now displayed in the
2965             ;; article buffer.
2966             (when (and (numberp article)
2967                        (not (eq article gnus-current-article)))
2968               ;; Seems like a new article has been selected.
2969               ;; `gnus-current-article' must be an article number.
2970               (save-excursion
2971                 (set-buffer summary-buffer)
2972                 (push article gnus-newsgroup-history)
2973                 (setq gnus-last-article gnus-current-article
2974                       gnus-current-article article
2975                       gnus-current-headers
2976                       (gnus-summary-article-header gnus-current-article)
2977                       gnus-article-current
2978                       (cons gnus-newsgroup-name gnus-current-article))
2979                 (unless (vectorp gnus-current-headers)
2980                   (setq gnus-current-headers nil))
2981                 (gnus-summary-goto-subject gnus-current-article)
2982                 (when (gnus-summary-show-thread)
2983                   ;; If the summary buffer really was folded, the
2984                   ;; previous goto may not actually have gone to
2985                   ;; the right article, but the thread root instead.
2986                   ;; So we go again.
2987                   (gnus-summary-goto-subject gnus-current-article))
2988                 (gnus-run-hooks 'gnus-mark-article-hook)
2989                 (gnus-set-mode-line 'summary)
2990                 (when (gnus-visual-p 'article-highlight 'highlight)
2991                   (gnus-run-hooks 'gnus-visual-mark-article-hook))
2992                 ;; Set the global newsgroup variables here.
2993                 (gnus-set-global-variables)
2994                 (setq gnus-have-all-headers
2995                       (or all-headers gnus-show-all-headers))))
2996             (when (or (numberp article)
2997                       (stringp article))
2998               (gnus-article-prepare-display)
2999               ;; Do page break.
3000               (goto-char (point-min))
3001               (setq gnus-page-broken
3002                     (when gnus-break-pages
3003                       (gnus-narrow-to-page)
3004                       t)))
3005             (let ((gnus-article-mime-handle-alist-1
3006                    gnus-article-mime-handle-alist))
3007               (gnus-set-mode-line 'article))
3008             (article-goto-body)
3009             (set-window-point (get-buffer-window (current-buffer)) (point))
3010             (gnus-configure-windows 'article)
3011             t))))))
3012
3013 (defun gnus-article-prepare-mime-display (&optional number)
3014   (goto-char (point-min))
3015   (when (re-search-forward "^[^\t ]+:" nil t)
3016     (goto-char (match-beginning 0)))
3017   (let ((entity (if (eq 1 (point-min))
3018                     (get-text-property 1 'mime-view-entity)
3019                   (get-text-property (point) 'mime-view-entity)))
3020         last-entity child-entity next type)
3021     (setq child-entity (mime-entity-children entity))
3022     (if child-entity
3023         (setq last-entity (nth (1- (length child-entity))
3024                                child-entity))
3025       (setq last-entity entity))
3026     (save-restriction
3027       (narrow-to-region (point)
3028                         (if (search-forward "\n\n" nil t)
3029                             (point)
3030                           (point-max)))
3031       (gnus-treat-article 'head)
3032       (put-text-property (point-min) (point-max) 'article-treated-header t)
3033       (goto-char (point-max)))
3034     (while (and (not (eobp)) entity)
3035       (setq next (set-marker
3036                   (make-marker)
3037                   (next-single-property-change (point) 'mime-view-entity
3038                                                nil (point-max))))
3039       (let ((types (mime-entity-content-type entity)))
3040         (while (eq 'multipart (mime-content-type-primary-type types))
3041           (setq entity (car (mime-entity-children entity))
3042                 types (mime-entity-content-type entity)))
3043         (when types
3044           (setq type (format "%s/%s"
3045                              (mime-content-type-primary-type types)
3046                              (mime-content-type-subtype types)))))
3047       (if (string-equal type "message/rfc822")
3048           (progn
3049             (setq next (point))
3050             (let ((children (mime-entity-children entity))
3051                   last-children)
3052               (when children
3053                 (setq last-children (nth (1- (length children)) children))
3054                 (while
3055                     (and
3056                      (not (eq last-children
3057                               (get-text-property next 'mime-view-entity)))
3058                      (setq next
3059                            (next-single-property-change next
3060                                                         'mime-view-entity
3061                                                         nil (point-max)))))))
3062             (setq next (next-single-property-change next 'mime-view-entity
3063                                                     nil (point-max)))
3064             (save-restriction
3065               (narrow-to-region (point) next)
3066               (gnus-article-prepare-mime-display)
3067               (goto-char (point-max)))
3068             (setq entity (get-text-property (point) 'mime-view-entity)))
3069         (save-restriction
3070           (narrow-to-region (point) next)
3071           ;; Kludge. We have to count true number, but for now,
3072           ;; part number is here only to achieve `last'.
3073           (gnus-treat-article nil 1
3074                               (if (eq entity last-entity)
3075                                   1 2)
3076                               type)
3077           (goto-char (point-max)))
3078         (setq entity (get-text-property next 'mime-view-entity))))))
3079
3080 ;;;###autoload
3081 (defun gnus-article-prepare-display ()
3082   "Make the current buffer look like a nice article."
3083   (setq gnus-article-wash-types nil)
3084   (gnus-run-hooks 'gnus-tmp-internal-hook)
3085   (gnus-run-hooks 'gnus-article-prepare-hook)
3086   ;; Display message.
3087   (let (mime-display-header-hook mime-display-text/plain-hook)
3088     (funcall (if gnus-show-mime
3089                  (progn
3090                    (setq mime-message-structure gnus-current-headers)
3091                    (mime-buffer-entity-set-buffer-internal
3092                     mime-message-structure
3093                     gnus-original-article-buffer)
3094                    (mime-entity-set-representation-type-internal
3095                     mime-message-structure 'mime-buffer-entity)
3096                    (luna-send mime-message-structure
3097                               'initialize-instance
3098                               mime-message-structure)
3099                    gnus-article-display-method-for-mime)
3100                gnus-article-display-method-for-traditional)))
3101   ;; Associate this article with the current summary buffer.
3102   (setq gnus-article-current-summary gnus-summary-buffer)
3103   ;; Call the treatment functions.
3104   (let ((inhibit-read-only t)
3105         buffer-read-only)
3106     (save-restriction
3107       (widen)
3108       (if gnus-show-mime
3109           (gnus-article-prepare-mime-display)
3110         (narrow-to-region (goto-char (point-min))
3111                           (if (search-forward "\n\n" nil t)
3112                               (point)
3113                             (point-max)))
3114         (gnus-treat-article 'head)
3115         (put-text-property (point-min) (point-max) 'article-treated-header t)
3116         (goto-char (point-max))
3117         (widen)
3118         (narrow-to-region (point) (point-max))
3119         (gnus-treat-article nil))
3120       (put-text-property (point-min) (point-max) 'read-only nil)))
3121   ;; Perform the article display hooks.  Incidentally, this hook is
3122   ;; an obsolete variable by now.
3123   (gnus-run-hooks 'gnus-article-display-hook))
3124
3125 (defun gnus-article-decode-article-as-default-mime-charset ()
3126   "Decode an article as `default-mime-charset'.  It won't work if the
3127 value of the variable `gnus-show-mime' is non-nil."
3128   (unless gnus-show-mime
3129     (decode-mime-charset-region (point-min) (point-max)
3130                                 (with-current-buffer gnus-summary-buffer
3131                                   default-mime-charset))))
3132
3133 ;;;
3134 ;;; Gnus MIME viewing functions
3135 ;;;
3136
3137 (defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
3138   "The following specs can be used:
3139 %t  The MIME type
3140 %T  MIME type, along with additional info
3141 %n  The `name' parameter
3142 %d  The description, if any
3143 %l  The length of the encoded part
3144 %p  The part identifier number
3145 %e  Dots if the part isn't displayed")
3146
3147 (defvar gnus-mime-button-line-format-alist
3148   '((?t gnus-tmp-type ?s)
3149     (?T gnus-tmp-type-long ?s)
3150     (?n gnus-tmp-name ?s)
3151     (?d gnus-tmp-description ?s)
3152     (?p gnus-tmp-id ?s)
3153     (?l gnus-tmp-length ?d)
3154     (?e gnus-tmp-dots ?s)))
3155
3156 (defvar gnus-mime-button-commands
3157   '((gnus-article-press-button "\r" "Toggle Display")
3158     (gnus-mime-view-part "v" "View Interactively...")
3159     (gnus-mime-view-part-as-type "t" "View As Type...")
3160     (gnus-mime-save-part "o" "Save...")
3161     (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
3162     (gnus-mime-inline-part "i" "View As Text, In This Buffer")
3163     (gnus-mime-internalize-part "E" "View Internally")
3164     (gnus-mime-externalize-part "e" "View Externally")
3165     (gnus-mime-pipe-part "|" "Pipe To Command...")))
3166
3167 (defun gnus-article-mime-part-status ()
3168   (with-current-buffer gnus-article-buffer
3169     (let ((entity (get-text-property (point-min) 'mime-view-entity)))
3170       (if (and entity (mime-entity-children entity))
3171           (format " (%d parts)" (length (mime-entity-children entity)))
3172         ""))))
3173
3174 (defvar gnus-mime-button-map nil)
3175 (unless gnus-mime-button-map
3176   (setq gnus-mime-button-map (make-sparse-keymap))
3177   (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
3178   (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
3179   (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu)
3180   (mapcar (lambda (c)
3181             (define-key gnus-mime-button-map (cadr c) (car c)))
3182           gnus-mime-button-commands))
3183
3184 (defun gnus-mime-button-menu (event)
3185   "Construct a context-sensitive menu of MIME commands."
3186   (interactive "e")
3187   (save-excursion
3188     (let ((pos (event-start event)))
3189       (set-buffer (window-buffer (posn-window pos)))
3190       (goto-char (posn-point pos))
3191       (gnus-article-check-buffer)
3192       (let ((response (x-popup-menu
3193                        t `("MIME Part"
3194                            ("" ,@(mapcar (lambda (c)
3195                                            (cons (caddr c) (car c)))
3196                                          gnus-mime-button-commands))))))
3197         (if response
3198             (funcall response))))))
3199
3200 (defun gnus-mime-view-all-parts (&optional handles)
3201   "View all the MIME parts."
3202   (interactive)
3203   (save-current-buffer
3204     (set-buffer gnus-article-buffer)
3205     (let ((handles (or handles gnus-article-mime-handles))
3206           (mail-parse-charset gnus-newsgroup-charset)
3207           (mail-parse-ignored-charsets
3208            (save-excursion (set-buffer gnus-summary-buffer)
3209                            gnus-newsgroup-ignored-charsets)))
3210       (if (stringp (car handles))
3211           (gnus-mime-view-all-parts (cdr handles))
3212         (mapcar 'mm-display-part handles)))))
3213
3214 (defun gnus-mime-save-part ()
3215   "Save the MIME part under point."
3216   (interactive)
3217   (gnus-article-check-buffer)
3218   (let ((data (get-text-property (point) 'gnus-data)))
3219     (mm-save-part data)))
3220
3221 (defun gnus-mime-pipe-part ()
3222   "Pipe the MIME part under point to a process."
3223   (interactive)
3224   (gnus-article-check-buffer)
3225   (let ((data (get-text-property (point) 'gnus-data)))
3226     (mm-pipe-part data)))
3227
3228 (defun gnus-mime-view-part ()
3229   "Interactively choose a viewing method for the MIME part under point."
3230   (interactive)
3231   (gnus-article-check-buffer)
3232   (let ((data (get-text-property (point) 'gnus-data)))
3233     (mm-interactively-view-part data)))
3234
3235 (defun gnus-mime-view-part-as-type-internal ()
3236   (gnus-article-check-buffer)
3237   (let* ((name (mail-content-type-get
3238                 (mm-handle-type (get-text-property (point) 'gnus-data))
3239                 'name))
3240          (def-type (and name (mm-default-file-encoding name))))
3241     (and def-type (cons def-type 0))))
3242
3243 (defun gnus-mime-view-part-as-type (mime-type)
3244   "Choose a MIME media type, and view the part as such."
3245   (interactive
3246    (list (completing-read
3247           "View as MIME type: "
3248           (mapcar (lambda (i) (list i i)) (mailcap-mime-types))
3249           nil nil
3250           (gnus-mime-view-part-as-type-internal))))
3251   (gnus-article-check-buffer)
3252   (let ((handle (get-text-property (point) 'gnus-data)))
3253     (gnus-mm-display-part
3254      (mm-make-handle (mm-handle-buffer handle)
3255                      (cons mime-type (cdr (mm-handle-type handle)))
3256                      (mm-handle-encoding handle)
3257                      (mm-handle-undisplayer handle)
3258                      (mm-handle-disposition handle)
3259                      (mm-handle-description handle)
3260                      (mm-handle-cache handle)
3261                      (mm-handle-id handle)))))
3262
3263 (defun gnus-mime-copy-part (&optional handle)
3264   "Put the the MIME part under point into a new buffer."
3265   (interactive)
3266   (gnus-article-check-buffer)
3267   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3268          (contents (mm-get-part handle))|
3269          (base (file-name-nondirectory
3270                 (or
3271                  (mail-content-type-get (mm-handle-type handle) 'name)
3272                  (mail-content-type-get (mm-handle-type handle)
3273                                         'filename)
3274                  "*decoded*")))
3275          (buffer (generate-new-buffer base)))
3276     (switch-to-buffer buffer)
3277     (insert contents)
3278     ;; We do it this way to make `normal-mode' set the appropriate mode.
3279     (unwind-protect
3280         (progn
3281           (setq buffer-file-name (expand-file-name base))
3282           (normal-mode))
3283       (setq buffer-file-name nil))
3284     (goto-char (point-min))))
3285
3286 (defun gnus-mime-inline-part (&optional handle)
3287   "Insert the MIME part under point into the current buffer."
3288   (interactive)
3289   (gnus-article-check-buffer)
3290   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3291          contents
3292          (b (point))
3293          buffer-read-only)
3294     (if (mm-handle-undisplayer handle)
3295         (mm-remove-part handle)
3296       (setq contents (mm-get-part handle))
3297       (forward-line 2)
3298       (mm-insert-inline handle contents)
3299       (goto-char b))))
3300
3301 (defun gnus-mime-externalize-part (&optional handle)
3302   "View the MIME part under point with an external viewer."
3303   (interactive)
3304   (gnus-article-check-buffer)
3305   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3306          (mm-user-display-methods nil)
3307          (mm-inline-large-images nil)
3308          (mail-parse-charset gnus-newsgroup-charset)
3309          (mail-parse-ignored-charsets
3310           (save-excursion (set-buffer gnus-summary-buffer)
3311                           gnus-newsgroup-ignored-charsets)))
3312     (if (mm-handle-undisplayer handle)
3313         (mm-remove-part handle)
3314       (mm-display-part handle))))
3315
3316 (defun gnus-mime-internalize-part (&optional handle)
3317   "View the MIME part under point with an internal viewer.
3318 In no internal viewer is available, use an external viewer."
3319   (interactive)
3320   (gnus-article-check-buffer)
3321   (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
3322          (mm-inlined-types '(".*"))
3323          (mm-inline-large-images t)
3324          (mail-parse-charset gnus-newsgroup-charset)
3325          (mail-parse-ignored-charsets
3326           (save-excursion (set-buffer gnus-summary-buffer)
3327                           gnus-newsgroup-ignored-charsets)))
3328     (if (mm-handle-undisplayer handle)
3329         (mm-remove-part handle)
3330       (mm-display-part handle))))
3331
3332 (defun gnus-article-part-wrapper (n function)
3333   (save-current-buffer
3334     (set-buffer gnus-article-buffer)
3335     (when (> n (length gnus-article-mime-handle-alist))
3336       (error "No such part"))
3337     (gnus-article-goto-part n)
3338     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3339       (funcall function handle))))
3340
3341 (defun gnus-article-pipe-part (n)
3342   "Pipe MIME part N, which is the numerical prefix."
3343   (interactive "p")
3344   (gnus-article-part-wrapper n 'mm-pipe-part))
3345
3346 (defun gnus-article-save-part (n)
3347   "Save MIME part N, which is the numerical prefix."
3348   (interactive "p")
3349   (gnus-article-part-wrapper n 'mm-save-part))
3350
3351 (defun gnus-article-interactively-view-part (n)
3352   "View MIME part N interactively, which is the numerical prefix."
3353   (interactive "p")
3354   (gnus-article-part-wrapper n 'mm-interactively-view-part))
3355
3356 (defun gnus-article-copy-part (n)
3357   "Copy MIME part N, which is the numerical prefix."
3358   (interactive "p")
3359   (gnus-article-part-wrapper n 'gnus-mime-copy-part))
3360
3361 (defun gnus-article-externalize-part (n)
3362   "View MIME part N externally, which is the numerical prefix."
3363   (interactive "p")
3364   (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
3365
3366 (defun gnus-article-inline-part (n)
3367   "Inline MIME part N, which is the numerical prefix."
3368   (interactive "p")
3369   (gnus-article-part-wrapper n 'gnus-mime-inline-part))
3370
3371 (defun gnus-article-mime-match-handle-first (condition)
3372   (if condition
3373       (let ((alist gnus-article-mime-handle-alist) ihandle n)
3374         (while (setq ihandle (pop alist))
3375           (if (and (cond
3376                     ((functionp condition)
3377                      (funcall condition (cdr ihandle)))
3378                     ((eq condition 'undisplayed)
3379                      (not (or (mm-handle-undisplayer (cdr ihandle))
3380                               (equal (mm-handle-media-type (cdr ihandle))
3381                                      "multipart/alternative"))))
3382                     ((eq condition 'undisplayed-alternative)
3383                      (not (mm-handle-undisplayer (cdr ihandle))))
3384                     (t t))
3385                    (gnus-article-goto-part (car ihandle))
3386                    (or (not n) (< (car ihandle) n)))
3387               (setq n (car ihandle))))
3388         (or n 1))
3389     1))
3390
3391 (defun gnus-article-view-part (&optional n)
3392   "View MIME part N, which is the numerical prefix."
3393   (interactive "P")
3394   (save-current-buffer
3395     (set-buffer gnus-article-buffer)
3396     (or (numberp n) (setq n (gnus-article-mime-match-handle-first
3397                              gnus-article-mime-match-handle-function)))
3398     (when (> n (length gnus-article-mime-handle-alist))
3399       (error "No such part"))
3400     (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
3401       (when (gnus-article-goto-part n)
3402         (if (equal (car handle) "multipart/alternative")
3403             (gnus-article-press-button)
3404           (when (eq (gnus-mm-display-part handle) 'internal)
3405             (gnus-set-window-start)))))))
3406
3407 (defun gnus-mm-display-part (handle)
3408   "Display HANDLE and fix MIME button."
3409   (let ((id (get-text-property (point) 'gnus-part))
3410         (point (point))
3411         buffer-read-only)
3412     (forward-line 1)
3413     (prog1
3414         (let ((window (selected-window))
3415               (mail-parse-charset gnus-newsgroup-charset)
3416               (mail-parse-ignored-charsets
3417                (save-excursion (set-buffer gnus-summary-buffer)
3418                                gnus-newsgroup-ignored-charsets)))
3419           (save-excursion
3420             (unwind-protect
3421                 (let ((win (get-buffer-window (current-buffer) t))
3422                       (beg (point)))
3423                   (when win
3424                     (select-window win))
3425                   (goto-char point)
3426                   (forward-line)
3427                   (if (mm-handle-displayed-p handle)
3428                       ;; This will remove the part.
3429                       (mm-display-part handle)
3430                     (save-restriction
3431                       (narrow-to-region (point) (1+ (point)))
3432                       (mm-display-part handle)
3433                       ;; We narrow to the part itself and
3434                       ;; then call the treatment functions.
3435                       (goto-char (point-min))
3436                       (forward-line 1)
3437                       (narrow-to-region (point) (point-max))
3438                       (gnus-treat-article
3439                        nil id
3440                        (1- (length gnus-article-mime-handles))
3441                        (mm-handle-media-type handle)))))
3442               (select-window window))))
3443       (goto-char point)
3444       (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
3445       (gnus-insert-mime-button
3446        handle id (list (mm-handle-displayed-p handle)))
3447       (goto-char point))))
3448
3449 (defun gnus-article-goto-part (n)
3450   "Go to MIME part N."
3451   (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
3452     (when point
3453       (goto-char point))))
3454
3455 (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
3456   (let ((gnus-tmp-name
3457          (or (mail-content-type-get (mm-handle-type handle)
3458                                     'name)
3459              (mail-content-type-get (mm-handle-disposition handle)
3460                                     'filename)
3461              ""))
3462         (gnus-tmp-type (mm-handle-media-type handle))
3463         (gnus-tmp-description
3464          (mail-decode-encoded-word-string (or (mm-handle-description handle)
3465                                               "")))
3466         (gnus-tmp-dots
3467          (if (if displayed (car displayed)
3468                (mm-handle-displayed-p handle))
3469              "" "..."))
3470         (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle)
3471                            (buffer-size)))
3472         gnus-tmp-type-long b e)
3473     (when (string-match ".*/" gnus-tmp-name)
3474       (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name)))
3475     (setq gnus-tmp-type-long (concat gnus-tmp-type
3476                                      (and (not (equal gnus-tmp-name ""))
3477                                           (concat "; " gnus-tmp-name))))
3478     (or (equal gnus-tmp-description "")
3479         (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
3480     (unless (bolp)
3481       (insert "\n"))
3482     (setq b (point))
3483     (gnus-eval-format
3484      gnus-mime-button-line-format gnus-mime-button-line-format-alist
3485      `(local-map ,gnus-mime-button-map
3486                  keymap ,gnus-mime-button-map
3487                  gnus-callback gnus-mm-display-part
3488                  gnus-part ,gnus-tmp-id
3489                  article-type annotation
3490                  gnus-data ,handle))
3491     (setq e (point))
3492     (widget-convert-button 'link b e
3493                            :mime-handle handle
3494                            :action 'gnus-widget-press-button
3495                            :button-keymap gnus-mime-button-map
3496                            :help-echo
3497                            (lambda (widget)
3498                              ;; Needed to properly clear the message
3499                              ;; due to a bug in wid-edit
3500                              (setq help-echo-owns-message t)
3501                              (format
3502                               "Click to %s the MIME part; %s for more options"
3503                               (if (mm-handle-displayed-p
3504                                    (widget-get widget :mime-handle))
3505                                   "hide" "show")
3506                               (if gnus-xemacs "button3" "mouse-3"))))))
3507
3508 (defun gnus-widget-press-button (elems el)
3509   (goto-char (widget-get elems :from))
3510   (gnus-article-press-button))
3511
3512 (defvar gnus-displaying-mime nil)
3513
3514 (defun gnus-display-mime (&optional ihandles)
3515   "Display the MIME parts."
3516   (save-excursion
3517     (save-selected-window
3518       (let ((window (get-buffer-window gnus-article-buffer))
3519             (point (point)))
3520         (when window
3521           (select-window window)
3522           ;; We have to do this since selecting the window
3523           ;; may change the point.  So we set the window point.
3524           (set-window-point window point)))
3525       (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
3526              buffer-read-only handle name type b e display)
3527         (when (and (not ihandles)
3528                    (not gnus-displaying-mime))
3529           ;; Top-level call; we clean up.
3530           (when gnus-article-mime-handles
3531             (mm-destroy-parts gnus-article-mime-handles)
3532             (setq gnus-article-mime-handle-alist nil));; A trick.
3533           (setq gnus-article-mime-handles handles)
3534           ;; We allow users to glean info from the handles.
3535           (when gnus-article-mime-part-function
3536             (gnus-mime-part-function handles)))
3537         (if (and handles
3538                  (or (not (stringp (car handles)))
3539                      (cdr handles)))
3540             (progn
3541               (when (and (not ihandles)
3542                          (not gnus-displaying-mime))
3543                 ;; Clean up for mime parts.
3544                 (article-goto-body)
3545                 (delete-region (point) (point-max)))
3546               (let ((gnus-displaying-mime t))
3547                 (gnus-mime-display-part handles)))
3548           (save-restriction
3549             (article-goto-body)
3550             (narrow-to-region (point) (point-max))
3551             (gnus-treat-article nil 1 1)
3552             (widen)))
3553         (unless ihandles
3554           ;; Highlight the headers.
3555           (save-excursion
3556             (save-restriction
3557               (article-goto-body)
3558               (narrow-to-region (point-min) (point))
3559               (gnus-treat-article 'head))))))))
3560
3561 (defvar gnus-mime-display-multipart-as-mixed nil)
3562
3563 (defun gnus-mime-display-part (handle)
3564   (cond
3565    ;; Single part.
3566    ((not (stringp (car handle)))
3567     (gnus-mime-display-single handle))
3568    ;; User-defined multipart
3569    ((cdr (assoc (car handle) gnus-mime-multipart-functions))
3570     (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
3571              handle))
3572    ;; multipart/alternative
3573    ((and (equal (car handle) "multipart/alternative")
3574          (not gnus-mime-display-multipart-as-mixed))
3575     (let ((id (1+ (length gnus-article-mime-handle-alist))))
3576       (push (cons id handle) gnus-article-mime-handle-alist)
3577       (gnus-mime-display-alternative (cdr handle) nil nil id)))
3578    ;; multipart/related
3579    ((and (equal (car handle) "multipart/related")
3580          (not gnus-mime-display-multipart-as-mixed))
3581     ;;;!!!We should find the start part, but we just default
3582     ;;;!!!to the first part.
3583     (gnus-mime-display-part (cadr handle)))
3584    ;; Other multiparts are handled like multipart/mixed.
3585    (t
3586     (gnus-mime-display-mixed (cdr handle)))))
3587
3588 (defun gnus-mime-part-function (handles)
3589   (if (stringp (car handles))
3590       (mapcar 'gnus-mime-part-function (cdr handles))
3591     (funcall gnus-article-mime-part-function handles)))
3592
3593 (defun gnus-mime-display-mixed (handles)
3594   (mapcar 'gnus-mime-display-part handles))
3595
3596 (defun gnus-mime-display-single (handle)
3597   (let ((type (mm-handle-media-type handle))
3598         (ignored gnus-ignored-mime-types)
3599         (not-attachment t)
3600         (move nil)
3601         display text)
3602     (catch 'ignored
3603       (progn
3604         (while ignored
3605           (when (string-match (pop ignored) type)
3606             (throw 'ignored nil)))
3607         (if (and (setq not-attachment
3608                        (and (not (mm-inline-override-p handle))
3609                             (or (not (mm-handle-disposition handle))
3610                                 (equal (car (mm-handle-disposition handle))
3611                                        "inline")
3612                                 (mm-attachment-override-p handle))))
3613                  (mm-automatic-display-p handle)
3614                  (or (mm-inlined-p handle)
3615                      (mm-automatic-external-display-p type)))
3616             (setq display t)
3617           (when (equal (mm-handle-media-supertype handle) "text")
3618             (setq text t)))
3619         (let ((id (1+ (length gnus-article-mime-handle-alist))))
3620           (push (cons id handle) gnus-article-mime-handle-alist)
3621           (when (or (not display)
3622                     (not (gnus-unbuttonized-mime-type-p type)))
3623             ;(gnus-article-insert-newline)
3624             (gnus-insert-mime-button
3625              handle id (list (or display (and not-attachment text))))
3626             (gnus-article-insert-newline)
3627             ;(gnus-article-insert-newline)
3628             (setq move t)))
3629         (let ((beg (point)))
3630           (cond
3631            (display
3632             (when move
3633               (forward-line -2)
3634               (setq beg (point)))
3635             (let ((mail-parse-charset gnus-newsgroup-charset)
3636                   (mail-parse-ignored-charsets
3637                    (save-excursion (condition-case ()
3638                                        (set-buffer gnus-summary-buffer)
3639                                      (error))
3640                                    gnus-newsgroup-ignored-charsets)))
3641               (mm-display-part handle t))
3642             (goto-char (point-max)))
3643            ((and text not-attachment)
3644             (when move
3645               (forward-line -2)
3646               (setq beg (point)))
3647             (gnus-article-insert-newline)
3648             (mm-insert-inline handle (mm-get-part handle))
3649             (goto-char (point-max))))
3650           ;; Do highlighting.
3651           (save-excursion
3652             (save-restriction
3653               (narrow-to-region beg (point))
3654               (gnus-treat-article
3655                nil (length gnus-article-mime-handle-alist)
3656                (1- (length gnus-article-mime-handles))
3657                (mm-handle-media-type handle)))))))))
3658
3659 (defun gnus-unbuttonized-mime-type-p (type)
3660   "Say whether TYPE is to be unbuttonized."
3661   (unless gnus-inhibit-mime-unbuttonizing
3662     (catch 'found
3663       (let ((types gnus-unbuttonized-mime-types))
3664         (while types
3665           (when (string-match (pop types) type)
3666             (throw 'found t)))))))
3667
3668 (defun gnus-article-insert-newline ()
3669   "Insert a newline, but mark it as undeletable."
3670   (gnus-put-text-property
3671    (point) (progn (insert "\n") (point)) 'gnus-undeletable t))
3672
3673 (defun gnus-mime-display-alternative (handles &optional preferred ibegend id)
3674   (let* ((preferred (or preferred (mm-preferred-alternative handles)))
3675          (ihandles handles)
3676          (point (point))
3677          handle buffer-read-only from props begend not-pref)
3678     (save-window-excursion
3679       (save-restriction
3680         (when ibegend
3681           (narrow-to-region (car ibegend)
3682                             (or (cdr ibegend)
3683                                 (progn
3684                                   (goto-char (car ibegend))
3685                                   (forward-line 2)
3686                                   (point))))
3687           (delete-region (point-min) (point-max))
3688           (mm-remove-parts handles))
3689         (setq begend (list (point-marker)))
3690         ;; Do the toggle.
3691         (unless (setq not-pref (cadr (member preferred ihandles)))
3692           (setq not-pref (car ihandles)))
3693         (when (or ibegend
3694                   (not (gnus-unbuttonized-mime-type-p
3695                         "multipart/alternative")))
3696           (gnus-add-text-properties
3697            (setq from (point))
3698            (progn
3699              (insert (format "%d.  " id))
3700              (point))
3701            `(gnus-callback
3702              (lambda (handles)
3703                (unless ,(not ibegend)
3704                  (setq gnus-article-mime-handle-alist
3705                        ',gnus-article-mime-handle-alist))
3706                (gnus-mime-display-alternative
3707                 ',ihandles ',not-pref ',begend ,id))
3708              local-map ,gnus-mime-button-map
3709              ,gnus-mouse-face-prop ,gnus-article-mouse-face
3710              face ,gnus-article-button-face
3711              keymap ,gnus-mime-button-map
3712              gnus-part ,id
3713              gnus-data ,handle))
3714           (widget-convert-button 'link from (point)
3715                                  :action 'gnus-widget-press-button
3716                                  :button-keymap gnus-widget-button-keymap)
3717           ;; Do the handles
3718           (while (setq handle (pop handles))
3719             (gnus-add-text-properties
3720              (setq from (point))
3721              (progn
3722                (insert (format "(%c) %-18s"
3723                                (if (equal handle preferred) ?* ? )
3724                                (mm-handle-media-type handle)))
3725                (point))
3726              `(gnus-callback
3727                (lambda (handles)
3728                  (unless ,(not ibegend)
3729                    (setq gnus-article-mime-handle-alist
3730                          ',gnus-article-mime-handle-alist))
3731                  (gnus-mime-display-alternative
3732                   ',ihandles ',handle ',begend ,id))
3733                local-map ,gnus-mime-button-map
3734                ,gnus-mouse-face-prop ,gnus-article-mouse-face
3735                face ,gnus-article-button-face
3736                keymap ,gnus-mime-button-map
3737                gnus-part ,id
3738                gnus-data ,handle))
3739             (widget-convert-button 'link from (point)
3740                                    :action 'gnus-widget-press-button
3741                                    :button-keymap gnus-widget-button-keymap)
3742             (insert "  "))
3743           (insert "\n\n"))
3744         (when preferred
3745           (if (stringp (car preferred))
3746               (gnus-display-mime preferred)
3747             (let ((mail-parse-charset gnus-newsgroup-charset)
3748                   (mail-parse-ignored-charsets
3749                    (save-excursion (set-buffer gnus-summary-buffer)
3750                                    gnus-newsgroup-ignored-charsets)))
3751               (mm-display-part preferred)
3752               ;; Do highlighting.
3753               (save-excursion
3754                 (save-restriction
3755                   (narrow-to-region (car begend) (point-max))
3756                   (gnus-treat-article
3757                    nil (length gnus-article-mime-handle-alist)
3758                    (1- (length gnus-article-mime-handles))
3759                    (mm-handle-media-type handle))))))
3760           (goto-char (point-max))
3761           (setcdr begend (point-marker)))))
3762     (when ibegend
3763       (goto-char point))))
3764
3765 (defun gnus-article-wash-status ()
3766   "Return a string which display status of article washing."
3767   (save-excursion
3768     (set-buffer gnus-article-buffer)
3769     (let ((cite (memq 'cite gnus-article-wash-types))
3770           (headers (memq 'headers gnus-article-wash-types))
3771           (boring (memq 'boring-headers gnus-article-wash-types))
3772           (pgp (memq 'pgp gnus-article-wash-types))
3773           (pem (memq 'pem gnus-article-wash-types))
3774           (signature (memq 'signature gnus-article-wash-types))
3775           (overstrike (memq 'overstrike gnus-article-wash-types))
3776           (emphasis (memq 'emphasis gnus-article-wash-types)))
3777       (format "%c%c%c%c%c%c%c"
3778               (if cite ?c ? )
3779               (if (or headers boring) ?h ? )
3780               (if (or pgp pem) ?p ? )
3781               (if signature ?s ? )
3782               (if overstrike ?o ? )
3783               (if gnus-show-mime ?m ? )
3784               (if emphasis ?e ? )))))
3785
3786 (fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
3787
3788 (defun gnus-article-maybe-hide-headers ()
3789   "Hide unwanted headers if `gnus-have-all-headers' is nil.
3790 Provided for backwards compatibility."
3791   (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
3792                  (not (save-excursion (set-buffer gnus-summary-buffer)
3793                                       gnus-have-all-headers)))
3794              (not gnus-inhibit-hiding))
3795     (gnus-article-hide-headers)))
3796
3797 ;;; Article savers.
3798
3799 (defun gnus-output-to-file (file-name)
3800   "Append the current article to a file named FILE-NAME."
3801   (let ((artbuf (current-buffer)))
3802     (with-temp-buffer
3803       (insert-buffer-substring artbuf)
3804       ;; Append newline at end of the buffer as separator, and then
3805       ;; save it to file.
3806       (goto-char (point-max))
3807       (insert "\n")
3808       (write-region-as-binary (point-min) (point-max) file-name 'append)
3809       t)))
3810
3811 (defun gnus-narrow-to-page (&optional arg)
3812   "Narrow the article buffer to a page.
3813 If given a numerical ARG, move forward ARG pages."
3814   (interactive "P")
3815   (setq arg (if arg (prefix-numeric-value arg) 0))
3816   (save-excursion
3817     (set-buffer gnus-article-buffer)
3818     (goto-char (point-min))
3819     (widen)
3820     ;; Remove any old next/prev buttons.
3821     (when (gnus-visual-p 'page-marker)
3822       (let ((buffer-read-only nil))
3823         (gnus-remove-text-with-property 'gnus-prev)
3824         (gnus-remove-text-with-property 'gnus-next)))
3825     (when
3826         (cond ((< arg 0)
3827                (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
3828               ((> arg 0)
3829                (re-search-forward page-delimiter nil 'move arg)))
3830       (goto-char (match-end 0)))
3831     (narrow-to-region
3832      (point)
3833      (if (re-search-forward page-delimiter nil 'move)
3834          (match-beginning 0)
3835        (point)))
3836     (when (and (gnus-visual-p 'page-marker)
3837                (not (= (point-min) 1)))
3838       (save-excursion
3839         (goto-char (point-min))
3840         (gnus-insert-prev-page-button)))
3841     (when (and (gnus-visual-p 'page-marker)
3842                (< (+ (point-max) 2) (buffer-size)))
3843       (save-excursion
3844         (goto-char (point-max))
3845         (gnus-insert-next-page-button)))))
3846
3847 ;; Article mode commands
3848
3849 (defun gnus-article-goto-next-page ()
3850   "Show the next page of the article."
3851   (interactive)
3852   (when (gnus-article-next-page)
3853     (goto-char (point-min))
3854     (gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
3855
3856 (defun gnus-article-goto-prev-page ()
3857   "Show the next page of the article."
3858   (interactive)
3859   (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
3860     (gnus-article-prev-page nil)))
3861
3862 (defun gnus-article-next-page (&optional lines)
3863   "Show the next page of the current article.
3864 If end of article, return non-nil.  Otherwise return nil.
3865 Argument LINES specifies lines to be scrolled up."
3866   (interactive "p")
3867   (let ((start (window-start))
3868         end-of-buffer end-of-page)
3869     (save-excursion
3870       (move-to-window-line -1)
3871       (if (<= (point) start)
3872           (progn
3873             (forward-line 2)
3874             (setq start (point)))
3875         (forward-line 1)
3876         (setq start nil))
3877       (unless (or (cond ((eq (1+ (buffer-size)) (point))
3878                          (and (pos-visible-in-window-p)
3879                               (setq end-of-buffer t)))
3880                         ((eobp)
3881                          (setq end-of-page t)))
3882                   (not lines))
3883         (move-to-window-line lines)
3884         (unless (search-backward "\n\n" nil t)
3885           (setq start (point)))))
3886     (cond (end-of-buffer t)
3887           (end-of-page
3888            (gnus-narrow-to-page 1)
3889            nil)
3890           (t
3891            (if start
3892                (set-window-start (selected-window) start)
3893              (let (window-pixel-scroll-increment)
3894                (scroll-up lines)))
3895            nil))))
3896
3897 (defun gnus-article-prev-page (&optional lines)
3898   "Show previous page of current article.
3899 Argument LINES specifies lines to be scrolled down."
3900   (interactive "p")
3901   (let (beginning-of-buffer beginning-of-page)
3902     (save-excursion
3903       (move-to-window-line 0)
3904       (cond ((eq 1 (point))
3905              (setq beginning-of-buffer t))
3906             ((bobp)
3907              (setq beginning-of-page t))))
3908     (cond (beginning-of-buffer)
3909           (beginning-of-page
3910            (gnus-narrow-to-page -1))
3911           (t
3912            (condition-case nil
3913                (let (window-pixel-scroll-increment)
3914                  (scroll-down lines))
3915              (beginning-of-buffer
3916               (goto-char (point-min))))))))
3917
3918 (defun gnus-article-refer-article ()
3919   "Read article specified by message-id around point."
3920   (interactive)
3921   (let ((point (point)))
3922     (search-forward ">" nil t)          ;Move point to end of "<....>".
3923     (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
3924         (let ((message-id (match-string 1)))
3925           (goto-char point)
3926           (set-buffer gnus-summary-buffer)
3927           (gnus-summary-refer-article message-id))
3928       (goto-char (point))
3929       (error "No references around point"))))
3930
3931 (defun gnus-article-show-summary ()
3932   "Reconfigure windows to show summary buffer."
3933   (interactive)
3934   (if (not (gnus-buffer-live-p gnus-summary-buffer))
3935       (error "There is no summary buffer for this article buffer")
3936     (gnus-article-set-globals)
3937     (gnus-configure-windows 'article)
3938     (gnus-summary-goto-subject gnus-current-article)
3939     (gnus-summary-position-point)))
3940
3941 (defun gnus-article-describe-briefly ()
3942   "Describe article mode commands briefly."
3943   (interactive)
3944   (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")))
3945
3946 (defun gnus-article-summary-command ()
3947   "Execute the last keystroke in the summary buffer."
3948   (interactive)
3949   (let ((obuf (current-buffer))
3950         (owin (current-window-configuration))
3951         func)
3952     (switch-to-buffer gnus-article-current-summary 'norecord)
3953     (setq func (lookup-key (current-local-map) (this-command-keys)))
3954     (call-interactively func)
3955     (set-buffer obuf)
3956     (set-window-configuration owin)
3957     (set-window-point (get-buffer-window (current-buffer)) (point))))
3958
3959 (defun gnus-article-summary-command-nosave ()
3960   "Execute the last keystroke in the summary buffer."
3961   (interactive)
3962   (let (func)
3963     (pop-to-buffer gnus-article-current-summary 'norecord)
3964     (setq func (lookup-key (current-local-map) (this-command-keys)))
3965     (call-interactively func)))
3966
3967 (defun gnus-article-check-buffer ()
3968   "Beep if not in an article buffer."
3969   (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
3970     (error "Command invoked outside of a Gnus article buffer")))
3971
3972 (defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
3973   "Read a summary buffer key sequence and execute it from the article buffer."
3974   (interactive "P")
3975   (gnus-article-check-buffer)
3976   (let ((nosaves
3977          '("q" "Q"  "c" "r" "R" "\C-c\C-f" "m"  "a" "f" "F"
3978            "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
3979            "=" "^" "\M-^" "|"))
3980         (nosave-but-article
3981          '("A\r"))
3982         (nosave-in-article
3983          '("\C-d"))
3984         (up-to-top
3985          '("n" "Gn" "p" "Gp"))
3986         keys new-sum-point)
3987     (save-excursion
3988       (set-buffer gnus-article-current-summary)
3989       (let (gnus-pick-mode)
3990         (push (or key last-command-event) unread-command-events)
3991         (setq keys (static-if (featurep 'xemacs)
3992                        (events-to-keys (read-key-sequence nil))
3993                      (read-key-sequence nil)))))
3994     (message "")
3995
3996     (if (or (member keys nosaves)
3997             (member keys nosave-but-article)
3998             (member keys nosave-in-article))
3999         (let (func)
4000           (save-window-excursion
4001             (pop-to-buffer gnus-article-current-summary 'norecord)
4002             ;; We disable the pick minor mode commands.
4003             (let (gnus-pick-mode)
4004               (setq func (lookup-key (current-local-map) keys))))
4005           (if (or (not func)
4006                   (numberp func))
4007               (ding)
4008             (unless (member keys nosave-in-article)
4009               (set-buffer gnus-article-current-summary))
4010             (call-interactively func)
4011             (setq new-sum-point (point)))
4012           (when (member keys nosave-but-article)
4013             (pop-to-buffer gnus-article-buffer 'norecord)))
4014       ;; These commands should restore window configuration.
4015       (let ((obuf (current-buffer))
4016             (owin (current-window-configuration))
4017             (opoint (point))
4018             (summary gnus-article-current-summary)
4019             func in-buffer selected)
4020         (if not-restore-window
4021             (pop-to-buffer summary 'norecord)
4022           (switch-to-buffer summary 'norecord))
4023         (setq in-buffer (current-buffer))
4024         ;; We disable the pick minor mode commands.
4025         (if (setq func (let (gnus-pick-mode)
4026                          (lookup-key (current-local-map) keys)))
4027             (progn
4028               (call-interactively func)
4029               (setq new-sum-point (point)))
4030           (ding))
4031         (when (eq in-buffer (current-buffer))
4032           (setq selected (gnus-summary-select-article))
4033           (set-buffer obuf)
4034           (unless not-restore-window
4035             (set-window-configuration owin))
4036           (when (eq selected 'old)
4037             (article-goto-body)
4038             (set-window-start (get-buffer-window (current-buffer))
4039                               1)
4040             (set-window-point (get-buffer-window (current-buffer))
4041                               (point)))
4042           (let ((win (get-buffer-window gnus-article-current-summary)))
4043             (when win
4044               (set-window-point win new-sum-point))))))))
4045
4046 (defun gnus-article-hide (&optional arg force)
4047   "Hide all the gruft in the current article.
4048 This means that PGP stuff, signatures, cited text and (some)
4049 headers will be hidden.
4050 If given a prefix, show the hidden text instead."
4051   (interactive (append (gnus-article-hidden-arg) (list 'force)))
4052   (gnus-article-hide-headers arg)
4053   (gnus-article-hide-list-identifiers arg)
4054   (gnus-article-hide-pgp arg)
4055   (gnus-article-hide-citation-maybe arg force)
4056   (gnus-article-hide-signature arg))
4057
4058 (defun gnus-article-maybe-highlight ()
4059   "Do some article highlighting if article highlighting is requested."
4060   (when (gnus-visual-p 'article-highlight 'highlight)
4061     (gnus-article-highlight-some)))
4062
4063 (defun gnus-check-group-server ()
4064   ;; Make sure the connection to the server is alive.
4065   (unless (gnus-server-opened
4066            (gnus-find-method-for-group gnus-newsgroup-name))
4067     (gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
4068     (gnus-request-group gnus-newsgroup-name t)))
4069
4070 (defun gnus-request-article-this-buffer (article group)
4071   "Get an article and insert it into this buffer."
4072   (let (do-update-line sparse-header)
4073     (prog1
4074         (save-excursion
4075           (erase-buffer)
4076           (gnus-kill-all-overlays)
4077           (setq group (or group gnus-newsgroup-name))
4078
4079           ;; Using `gnus-request-article' directly will insert the article into
4080           ;; `nntp-server-buffer' - so we'll save some time by not having to
4081           ;; copy it from the server buffer into the article buffer.
4082
4083           ;; We only request an article by message-id when we do not have the
4084           ;; headers for it, so we'll have to get those.
4085           (when (stringp article)
4086             (gnus-read-header article))
4087
4088           ;; If the article number is negative, that means that this article
4089           ;; doesn't belong in this newsgroup (possibly), so we find its
4090           ;; message-id and request it by id instead of number.
4091           (when (and (numberp article)
4092                      gnus-summary-buffer
4093                      (get-buffer gnus-summary-buffer)
4094                      (gnus-buffer-exists-p gnus-summary-buffer))
4095             (save-excursion
4096               (set-buffer gnus-summary-buffer)
4097               (let ((header (gnus-summary-article-header article)))
4098                 (when (< article 0)
4099                   (cond
4100                    ((memq article gnus-newsgroup-sparse)
4101                     ;; This is a sparse gap article.
4102                     (setq do-update-line article)
4103                     (setq article (mail-header-id header))
4104                     (setq sparse-header (gnus-read-header article))
4105                     (setq gnus-newsgroup-sparse
4106                           (delq article gnus-newsgroup-sparse)))
4107                    ((vectorp header)
4108                     ;; It's a real article.
4109                     (setq article (mail-header-id header)))
4110                    (t
4111                     ;; It is an extracted pseudo-article.
4112                     (setq article 'pseudo)
4113                     (gnus-request-pseudo-article header))))
4114
4115                 (let ((method (gnus-find-method-for-group
4116                                gnus-newsgroup-name)))
4117                   (when (and (eq (car method) 'nneething)
4118                              (vectorp header))
4119                     (let ((dir (concat
4120                                 (file-name-as-directory
4121                                  (or (cadr (assq 'nneething-address method))
4122                                      (nth 1 method)))
4123                                 (mail-header-subject header))))
4124                       (when (file-directory-p dir)
4125                         (setq article 'nneething)
4126                         (gnus-group-enter-directory dir))))))))
4127
4128           (cond
4129            ;; Refuse to select canceled articles.
4130            ((and (numberp article)
4131                  gnus-summary-buffer
4132                  (get-buffer gnus-summary-buffer)
4133                  (gnus-buffer-exists-p gnus-summary-buffer)
4134                  (eq (cdr (save-excursion
4135                             (set-buffer gnus-summary-buffer)
4136                             (assq article gnus-newsgroup-reads)))
4137                      gnus-canceled-mark))
4138             nil)
4139            ;; Check the backlog.
4140            ((and gnus-keep-backlog
4141                  (gnus-backlog-request-article group article (current-buffer)))
4142             'article)
4143            ;; Check asynchronous pre-fetch.
4144            ((gnus-async-request-fetched-article group article (current-buffer))
4145             (gnus-async-prefetch-next group article gnus-summary-buffer)
4146             (when (and (numberp article) gnus-keep-backlog)
4147               (gnus-backlog-enter-article group article (current-buffer)))
4148             'article)
4149            ;; Check the cache.
4150            ((and gnus-use-cache
4151                  (numberp article)
4152                  (gnus-cache-request-article article group))
4153             'article)
4154            ;; Get the article and put into the article buffer.
4155            ((or (stringp article)
4156                 (numberp article))
4157             (let ((gnus-override-method gnus-override-method)
4158                   (methods (and (stringp article)
4159                                 gnus-refer-article-method))
4160                   result
4161                   (buffer-read-only nil))
4162               (setq methods
4163                     (if (listp methods)
4164                         methods
4165                       (list methods)))
4166               (when (and (null gnus-override-method)
4167                          methods)
4168                 (setq gnus-override-method (pop methods)))
4169               (while (not result)
4170                 (when (eq gnus-override-method 'current)
4171                   (setq gnus-override-method gnus-current-select-method))
4172                 (erase-buffer)
4173                 (gnus-kill-all-overlays)
4174                 (let ((gnus-newsgroup-name group))
4175                   (gnus-check-group-server))
4176                 (when (gnus-request-article article group (current-buffer))
4177                   (when (numberp article)
4178                     (gnus-async-prefetch-next group article
4179                                               gnus-summary-buffer)
4180                     (when gnus-keep-backlog
4181                       (gnus-backlog-enter-article
4182                        group article (current-buffer))))
4183                   (setq result 'article))
4184                 (if (not result)
4185                     (if methods
4186                         (setq gnus-override-method (pop methods))
4187                       (setq result 'done))))
4188               (and (eq result 'article) 'article)))
4189            ;; It was a pseudo.
4190            (t article)))
4191
4192       ;; Associate this article with the current summary buffer.
4193       (setq gnus-article-current-summary gnus-summary-buffer)
4194
4195       ;; Take the article from the original article buffer
4196       ;; and place it in the buffer it's supposed to be in.
4197       (when (and (get-buffer gnus-article-buffer)
4198                  (equal (buffer-name (current-buffer))
4199                         (buffer-name (get-buffer gnus-article-buffer))))
4200         (save-excursion
4201           (if (get-buffer gnus-original-article-buffer)
4202               (set-buffer gnus-original-article-buffer)
4203             (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
4204             (buffer-disable-undo)
4205             (setq major-mode 'gnus-original-article-mode)
4206             (setq buffer-read-only t))
4207           (let (buffer-read-only)
4208             (erase-buffer)
4209             (insert-buffer-substring gnus-article-buffer))
4210           (setq gnus-original-article (cons group article)))
4211
4212         ;; Decode charsets.
4213         (run-hooks 'gnus-article-decode-hook)
4214         ;; Mark article as decoded or not.
4215         (setq gnus-article-decoded-p gnus-article-decode-hook))
4216
4217       ;; Update sparse articles.
4218       (when (and do-update-line
4219                  (or (numberp article)
4220                      (stringp article)))
4221         (let ((buf (current-buffer)))
4222           (set-buffer gnus-summary-buffer)
4223           (gnus-summary-update-article do-update-line sparse-header)
4224           (gnus-summary-goto-subject do-update-line nil t)
4225           (set-window-point (get-buffer-window (current-buffer) t)
4226                             (point))
4227           (set-buffer buf))))))
4228
4229 ;;;
4230 ;;; Article editing
4231 ;;;
4232
4233 (defcustom gnus-article-edit-mode-hook nil
4234   "Hook run in article edit mode buffers."
4235   :group 'gnus-article-various
4236   :type 'hook)
4237
4238 (defcustom gnus-article-edit-article-setup-function
4239   'gnus-article-mime-edit-article-setup
4240   "Function called to setup an editing article buffer."
4241   :group 'gnus-article-various
4242   :type 'function)
4243
4244 (defvar gnus-article-edit-done-function nil)
4245
4246 (defvar gnus-article-edit-mode-map nil)
4247
4248 ;; Should we be using derived.el for this?
4249 (unless gnus-article-edit-mode-map
4250   (setq gnus-article-edit-mode-map (make-sparse-keymap))
4251   (set-keymap-parent gnus-article-edit-mode-map text-mode-map)
4252
4253   (gnus-define-keys gnus-article-edit-mode-map
4254     "\C-c\C-c" gnus-article-edit-done
4255     "\C-c\C-k" gnus-article-edit-exit)
4256
4257   (gnus-define-keys (gnus-article-edit-wash-map
4258                      "\C-c\C-w" gnus-article-edit-mode-map)
4259     "f" gnus-article-edit-full-stops))
4260
4261 (defun gnus-article-edit-mode ()
4262   "Major mode for editing articles.
4263 This is an extended text-mode.
4264
4265 \\{gnus-article-edit-mode-map}"
4266   (interactive)
4267   (setq major-mode 'gnus-article-edit-mode)
4268   (setq mode-name "Article Edit")
4269   (use-local-map gnus-article-edit-mode-map)
4270   (make-local-variable 'gnus-article-edit-done-function)
4271   (make-local-variable 'gnus-prev-winconf)
4272   (setq buffer-read-only nil)
4273   (buffer-enable-undo)
4274   (widen)
4275   (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
4276
4277 (defun gnus-article-edit (&optional force)
4278   "Edit the current article.
4279 This will have permanent effect only in mail groups.
4280 If FORCE is non-nil, allow editing of articles even in read-only
4281 groups."
4282   (interactive "P")
4283   (when (and (not force)
4284              (gnus-group-read-only-p))
4285     (error "The current newsgroup does not support article editing"))
4286   (gnus-article-date-original)
4287   (gnus-article-edit-article
4288    'ignore
4289    `(lambda (no-highlight)
4290       'ignore
4291       (gnus-summary-edit-article-done
4292        ,(or (mail-header-references gnus-current-headers) "")
4293        ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
4294
4295 (defun gnus-article-edit-article (start-func exit-func)
4296   "Start editing the contents of the current article buffer."
4297   (let ((winconf (current-window-configuration)))
4298     (set-buffer gnus-article-buffer)
4299     (gnus-article-edit-mode)
4300     (funcall start-func)
4301     (gnus-configure-windows 'edit-article)
4302     (setq gnus-article-edit-done-function exit-func)
4303     (setq gnus-prev-winconf winconf)
4304     (when gnus-article-edit-article-setup-function
4305       (funcall gnus-article-edit-article-setup-function))
4306     (gnus-message 6 "C-c C-c to end edits")))
4307
4308 (defun gnus-article-edit-done (&optional arg)
4309   "Update the article edits and exit."
4310   (interactive "P")
4311   (save-excursion
4312     (save-restriction
4313       (widen)
4314       (when (article-goto-body)
4315         (let ((lines (count-lines (point) (point-max)))
4316               (length (- (point-max) (point)))
4317               (case-fold-search t)
4318               (body (copy-marker (point))))
4319           (goto-char (point-min))
4320           (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
4321             (delete-region (match-beginning 1) (match-end 1))
4322             (insert (number-to-string length)))
4323           (goto-char (point-min))
4324           (when (re-search-forward
4325                  "^x-content-length:[ \t]\\([0-9]+\\)" body t)
4326             (delete-region (match-beginning 1) (match-end 1))
4327             (insert (number-to-string length)))
4328           (goto-char (point-min))
4329           (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
4330             (delete-region (match-beginning 1) (match-end 1))
4331             (insert (number-to-string lines)))))))
4332   (let ((func gnus-article-edit-done-function)
4333         (buf (current-buffer))
4334         (start (window-start)))
4335     (remove-hook 'gnus-article-mode-hook
4336                  'gnus-article-mime-edit-article-unwind)
4337     (gnus-article-edit-exit)
4338     (save-excursion
4339       (set-buffer buf)
4340       (let ((buffer-read-only nil))
4341         (funcall func arg))
4342       ;; The cache and backlog have to be flushed somewhat.
4343       (when gnus-keep-backlog
4344         (gnus-backlog-remove-article
4345          (car gnus-article-current) (cdr gnus-article-current)))
4346       ;; Flush original article as well.
4347       (save-excursion
4348         (when (get-buffer gnus-original-article-buffer)
4349           (set-buffer gnus-original-article-buffer)
4350           (setq gnus-original-article nil)))
4351       (when gnus-use-cache
4352         (gnus-cache-update-article
4353          (car gnus-article-current) (cdr gnus-article-current))))
4354     (set-buffer buf)
4355     (set-window-start (get-buffer-window buf) start)
4356     (set-window-point (get-buffer-window buf) (point))))
4357
4358 (defun gnus-article-edit-exit ()
4359   "Exit the article editing without updating."
4360   (interactive)
4361   ;; We remove all text props from the article buffer.
4362   (let ((buf (format "%s" (buffer-string)))
4363         (curbuf (current-buffer))
4364         (p (point))
4365         (window-start (window-start)))
4366     (erase-buffer)
4367     (insert buf)
4368     (let ((winconf gnus-prev-winconf))
4369       (gnus-article-mode)
4370       (set-window-configuration winconf)
4371       ;; Tippy-toe some to make sure that point remains where it was.
4372       (save-current-buffer
4373         (set-buffer curbuf)
4374         (set-window-start (get-buffer-window (current-buffer)) window-start)
4375         (goto-char p)))))
4376
4377 (defun gnus-article-edit-full-stops ()
4378   "Interactively repair spacing at end of sentences."
4379   (interactive)
4380   (save-excursion
4381     (goto-char (point-min))
4382     (search-forward-regexp "^$" nil t)
4383     (let ((case-fold-search nil))
4384       (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
4385
4386 ;;;
4387 ;;; Article editing with MIME-Edit
4388 ;;;
4389
4390 (defcustom gnus-article-mime-edit-article-setup-hook nil
4391   "Hook run after setting up a MIME editing article buffer."
4392   :group 'gnus-article-various
4393   :type 'hook)
4394
4395 (defun gnus-article-mime-edit-article-unwind ()
4396   "Unwind `gnus-article-buffer' if article editing was given up."
4397   (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
4398   (when mime-edit-mode-flag
4399     (mime-edit-exit 'nomime 'no-error)
4400     (message ""))
4401   (when (featurep 'font-lock)
4402     (setq font-lock-defaults nil)
4403     (font-lock-mode 0)))
4404
4405 (defun gnus-article-mime-edit-article-setup ()
4406   "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
4407 after replacing with the original article."
4408   (setq gnus-show-mime t)
4409   (setq gnus-article-edit-done-function
4410         `(lambda (&rest args)
4411            (when mime-edit-mode-flag
4412              (mime-edit-exit)
4413              (message ""))
4414            (goto-char (point-min))
4415            (let (case-fold-search)
4416              (when (re-search-forward
4417                     (format "^%s$" (regexp-quote mail-header-separator))
4418                     nil t)
4419                (replace-match "")))
4420            (when (featurep 'font-lock)
4421              (setq font-lock-defaults nil)
4422              (font-lock-mode 0))
4423            (apply ,gnus-article-edit-done-function args)
4424            (set-buffer gnus-original-article-buffer)
4425            (erase-buffer)
4426            (insert-buffer gnus-article-buffer)
4427            (setq gnus-current-headers (gnus-article-make-full-mail-header))
4428            (gnus-article-prepare-display)))
4429   (substitute-key-definition
4430    'gnus-article-edit-exit 'gnus-article-mime-edit-exit
4431    gnus-article-edit-mode-map)
4432   (erase-buffer)
4433   (insert-buffer gnus-original-article-buffer)
4434   (mime-edit-again)
4435   (when (featurep 'font-lock)
4436     (set (make-local-variable 'font-lock-defaults)
4437          '(message-font-lock-keywords t))
4438     (font-lock-set-defaults)
4439     (turn-on-font-lock))
4440   (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
4441   (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
4442
4443 (defun gnus-article-mime-edit-exit ()
4444   "Exit the article MIME editing without updating."
4445   (interactive)
4446   (let ((winconf gnus-prev-winconf)
4447         buf)
4448     (when mime-edit-mode-flag
4449       (mime-edit-exit)
4450       (message ""))
4451     (goto-char (point-min))
4452     (let (case-fold-search)
4453       (when (re-search-forward
4454              (format "^%s$" (regexp-quote mail-header-separator)) nil t)
4455         (replace-match "")))
4456     (when (featurep 'font-lock)
4457       (setq font-lock-defaults nil)
4458       (font-lock-mode 0))
4459     ;; We remove all text props from the article buffer.
4460     (setq buf (format "%s" (buffer-string)))
4461     (set-buffer (get-buffer-create gnus-original-article-buffer))
4462     (erase-buffer)
4463     (insert buf)
4464     (setq gnus-current-headers (gnus-article-make-full-mail-header))
4465     (gnus-article-prepare-display)
4466     (set-window-configuration winconf)))
4467
4468 ;;;
4469 ;;; Article highlights
4470 ;;;
4471
4472 ;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
4473
4474 ;;; Internal Variables:
4475
4476 (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\\)\\)\\|[-a-zA-Z0-9_]+\\.[-a-zA-Z0-9_]+\\(\\.[-a-zA-Z0-9_]+[-a-zA-Z0-9_/]+\\)+"
4477   "Regular expression that matches URLs."
4478   :group 'gnus-article-buttons
4479   :type 'regexp)
4480
4481 (defcustom gnus-button-alist
4482   `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
4483      0 t gnus-button-message-id 2)
4484     ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1)
4485     ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
4486      1 t
4487      gnus-button-fetch-group 4)
4488     ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
4489     ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
4490      t gnus-button-message-id 3)
4491     ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>" 0 t gnus-url-mailto 2)
4492     ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
4493     ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
4494     ;; This is how URLs _should_ be embedded in text...
4495     ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
4496     ;; Raw URLs.
4497     (,gnus-button-url-regexp 0 t browse-url 0))
4498   "*Alist of regexps matching buttons in article bodies.
4499
4500 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
4501 REGEXP: is the string matching text around the button,
4502 BUTTON: is the number of the regexp grouping actually matching the button,
4503 FORM: is a lisp expression which must eval to true for the button to
4504 be added,
4505 CALLBACK: is the function to call when the user push this button, and each
4506 PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
4507
4508 CALLBACK can also be a variable, in that case the value of that
4509 variable it the real callback function."
4510   :group 'gnus-article-buttons
4511   :type '(repeat (list regexp
4512                        (integer :tag "Button")
4513                        (sexp :tag "Form")
4514                        (function :tag "Callback")
4515                        (repeat :tag "Par"
4516                                :inline t
4517                                (integer :tag "Regexp group")))))
4518
4519 (defcustom gnus-header-button-alist
4520   `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
4521      0 t gnus-button-message-id 0)
4522     ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
4523     ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
4524      0 t gnus-button-mailto 0)
4525     ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0)
4526     ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0)
4527     ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0)
4528     ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
4529      gnus-button-message-id 3))
4530   "*Alist of headers and regexps to match buttons in article heads.
4531
4532 This alist is very similar to `gnus-button-alist', except that each
4533 alist has an additional HEADER element first in each entry:
4534
4535 \(HEADER REGEXP BUTTON FORM CALLBACK PAR)
4536
4537 HEADER is a regexp to match a header.  For a fuller explanation, see
4538 `gnus-button-alist'."
4539   :group 'gnus-article-buttons
4540   :group 'gnus-article-headers
4541   :type '(repeat (list (regexp :tag "Header")
4542                        regexp
4543                        (integer :tag "Button")
4544                        (sexp :tag "Form")
4545                        (function :tag "Callback")
4546                        (repeat :tag "Par"
4547                                :inline t
4548                                (integer :tag "Regexp group")))))
4549
4550 (defvar gnus-button-regexp nil)
4551 (defvar gnus-button-marker-list nil)
4552 ;; Regexp matching any of the regexps from `gnus-button-alist'.
4553
4554 (defvar gnus-button-last nil)
4555 ;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
4556
4557 ;;; Commands:
4558
4559 (defun gnus-article-push-button (event)
4560   "Check text under the mouse pointer for a callback function.
4561 If the text under the mouse pointer has a `gnus-callback' property,
4562 call it with the value of the `gnus-data' text property."
4563   (interactive "e")
4564   (set-buffer (window-buffer (posn-window (event-start event))))
4565   (let* ((pos (posn-point (event-start event)))
4566          (data (get-text-property pos 'gnus-data))
4567          (fun (get-text-property pos 'gnus-callback)))
4568     (goto-char pos)
4569     (when fun
4570       (funcall fun data))))
4571
4572 (defun gnus-article-press-button ()
4573   "Check text at point for a callback function.
4574 If the text at point has a `gnus-callback' property,
4575 call it with the value of the `gnus-data' text property."
4576   (interactive)
4577   (let* ((data (get-text-property (point) 'gnus-data))
4578          (fun (get-text-property (point) 'gnus-callback)))
4579     (when fun
4580       (funcall fun data))))
4581
4582 (defun gnus-article-prev-button (n)
4583   "Move point to N buttons backward.
4584 If N is negative, move forward instead."
4585   (interactive "p")
4586   (gnus-article-next-button (- n)))
4587
4588 (defun gnus-article-next-button (n)
4589   "Move point to N buttons forward.
4590 If N is negative, move backward instead."
4591   (interactive "p")
4592   (let ((function (if (< n 0) 'previous-single-property-change
4593                     'next-single-property-change))
4594         (inhibit-point-motion-hooks t)
4595         (backward (< n 0))
4596         (limit (if (< n 0) (point-min) (point-max))))
4597     (setq n (abs n))
4598     (while (and (not (= limit (point)))
4599                 (> n 0))
4600       ;; Skip past the current button.
4601       (when (get-text-property (point) 'gnus-callback)
4602         (goto-char (funcall function (point) 'gnus-callback nil limit)))
4603       ;; Go to the next (or previous) button.
4604       (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
4605       ;; Put point at the start of the button.
4606       (when (and backward (not (get-text-property (point) 'gnus-callback)))
4607         (goto-char (funcall function (point) 'gnus-callback nil limit)))
4608       ;; Skip past intangible buttons.
4609       (when (get-text-property (point) 'intangible)
4610         (incf n))
4611       (decf n))
4612     (unless (zerop n)
4613       (gnus-message 5 "No more buttons"))
4614     n))
4615
4616 (defun gnus-article-highlight (&optional force)
4617   "Highlight current article.
4618 This function calls `gnus-article-highlight-headers',
4619 `gnus-article-highlight-citation',
4620 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4621 do the highlighting.  See the documentation for those functions."
4622   (interactive (list 'force))
4623   (gnus-article-highlight-headers)
4624   (gnus-article-highlight-citation force)
4625   (gnus-article-highlight-signature)
4626   (gnus-article-add-buttons force)
4627   (gnus-article-add-buttons-to-head))
4628
4629 (defun gnus-article-highlight-some (&optional force)
4630   "Highlight current article.
4631 This function calls `gnus-article-highlight-headers',
4632 `gnus-article-highlight-signature', and `gnus-article-add-buttons' to
4633 do the highlighting.  See the documentation for those functions."
4634   (interactive (list 'force))
4635   (gnus-article-highlight-headers)
4636   (gnus-article-highlight-signature)
4637   (gnus-article-add-buttons))
4638
4639 (defun gnus-article-highlight-headers ()
4640   "Highlight article headers as specified by `gnus-header-face-alist'."
4641   (interactive)
4642   (save-excursion
4643     (set-buffer gnus-article-buffer)
4644     (save-restriction
4645       (let ((alist gnus-header-face-alist)
4646             (buffer-read-only nil)
4647             (case-fold-search t)
4648             (inhibit-point-motion-hooks t)
4649             entry regexp header-face field-face from hpoints fpoints)
4650         (article-narrow-to-head)
4651         (while (setq entry (pop alist))
4652           (goto-char (point-min))
4653           (setq regexp (concat "^\\("
4654                                (if (string-equal "" (nth 0 entry))
4655                                    "[^\t ]"
4656                                  (nth 0 entry))
4657                                "\\)")
4658                 header-face (nth 1 entry)
4659                 field-face (nth 2 entry))
4660           (while (and (re-search-forward regexp nil t)
4661                       (not (eobp)))
4662             (beginning-of-line)
4663             (setq from (point))
4664             (unless (search-forward ":" nil t)
4665               (forward-char 1))
4666             (when (and header-face
4667                        (not (memq (point) hpoints)))
4668               (push (point) hpoints)
4669               (gnus-put-text-property from (point) 'face header-face))
4670             (when (and field-face
4671                        (not (memq (setq from (point)) fpoints)))
4672               (push from fpoints)
4673               (if (re-search-forward "^[^ \t]" nil t)
4674                   (forward-char -2)
4675                 (goto-char (point-max)))
4676               (gnus-put-text-property from (point) 'face field-face))))))))
4677
4678 (defun gnus-article-highlight-signature ()
4679   "Highlight the signature in an article.
4680 It does this by highlighting everything after
4681 `gnus-signature-separator' using `gnus-signature-face'."
4682   (interactive)
4683   (when gnus-signature-face
4684     (save-excursion
4685       (set-buffer gnus-article-buffer)
4686       (let ((buffer-read-only nil)
4687             (inhibit-point-motion-hooks t))
4688         (save-restriction
4689           (when (gnus-article-narrow-to-signature)
4690             (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
4691                               'face gnus-signature-face)))))))
4692
4693 (defun gnus-article-buttonize-signature ()
4694   "Add button to the signature."
4695   (interactive)
4696   (save-excursion
4697     (set-buffer gnus-article-buffer)
4698     (let ((buffer-read-only nil)
4699           (inhibit-point-motion-hooks t))
4700       (when (gnus-article-search-signature)
4701         (gnus-article-add-button (match-beginning 0) (match-end 0)
4702                                  'gnus-signature-toggle
4703                                  (set-marker (make-marker)
4704                                              (1+ (match-end 0))))))))
4705
4706 (defun gnus-button-in-region-p (b e prop)
4707   "Say whether PROP exists in the region."
4708   (text-property-not-all b e prop nil))
4709
4710 (defun gnus-article-add-buttons (&optional force)
4711   "Find external references in the article and make buttons of them.
4712 \"External references\" are things like Message-IDs and URLs, as
4713 specified by `gnus-button-alist'."
4714   (interactive (list 'force))
4715   (save-excursion
4716     (set-buffer gnus-article-buffer)
4717     (let ((buffer-read-only nil)
4718           (inhibit-point-motion-hooks t)
4719           (case-fold-search t)
4720           (alist gnus-button-alist)
4721           beg entry regexp)
4722       ;; Remove all old markers.
4723       (let (marker entry new-list)
4724         (while (setq marker (pop gnus-button-marker-list))
4725           (if (or (< marker (point-min)) (>= marker (point-max)))
4726               (push marker new-list)
4727             (goto-char marker)
4728             (when (setq entry (gnus-button-entry))
4729               (put-text-property (match-beginning (nth 1 entry))
4730                                  (match-end (nth 1 entry))
4731                                  'gnus-callback nil))
4732             (set-marker marker nil)))
4733         (setq gnus-button-marker-list new-list))
4734       ;; We skip the headers.
4735       (article-goto-body)
4736       (setq beg (point))
4737       (while (setq entry (pop alist))
4738         (setq regexp (car entry))
4739         (goto-char beg)
4740         (while (re-search-forward regexp nil t)
4741           (let* ((start (and entry (match-beginning (nth 1 entry))))
4742                  (end (and entry (match-end (nth 1 entry))))
4743                  (from (match-beginning 0)))
4744             (when (and (or (eq t (nth 2 entry))
4745                            (eval (nth 2 entry)))
4746                        (not (gnus-button-in-region-p
4747                              start end 'gnus-callback)))
4748               ;; That optional form returned non-nil, so we add the
4749               ;; button.
4750               (gnus-article-add-button
4751                start end 'gnus-button-push
4752                (car (push (set-marker (make-marker) from)
4753                           gnus-button-marker-list))))))))))
4754
4755 ;; Add buttons to the head of an article.
4756 (defun gnus-article-add-buttons-to-head ()
4757   "Add buttons to the head of the article."
4758   (interactive)
4759   (save-excursion
4760     (set-buffer gnus-article-buffer)
4761     (save-restriction
4762       (let ((buffer-read-only nil)
4763             (inhibit-point-motion-hooks t)
4764             (case-fold-search t)
4765             (alist gnus-header-button-alist)
4766             entry beg end)
4767         (article-narrow-to-head)
4768         (while alist
4769           ;; Each alist entry.
4770           (setq entry (car alist)
4771                 alist (cdr alist))
4772           (goto-char (point-min))
4773           (while (re-search-forward (car entry) nil t)
4774             ;; Each header matching the entry.
4775             (setq beg (match-beginning 0))
4776             (setq end (or (and (re-search-forward "^[^ \t]" nil t)
4777                                (match-beginning 0))
4778                           (point-max)))
4779             (goto-char beg)
4780             (while (re-search-forward (nth 1 entry) end t)
4781               ;; Each match within a header.
4782               (let* ((entry (cdr entry))
4783                      (start (match-beginning (nth 1 entry)))
4784                      (end (match-end (nth 1 entry)))
4785                      (form (nth 2 entry)))
4786                 (goto-char (match-end 0))
4787                 (when (eval form)
4788                   (gnus-article-add-button
4789                    start end (nth 3 entry)
4790                    (buffer-substring (match-beginning (nth 4 entry))
4791                                      (match-end (nth 4 entry)))))))
4792             (goto-char end)))))))
4793
4794 ;;; External functions:
4795
4796 (defun gnus-article-add-button (from to fun &optional data)
4797   "Create a button between FROM and TO with callback FUN and data DATA."
4798   (when gnus-article-button-face
4799     (gnus-overlay-put (gnus-make-overlay from to)
4800                       'face gnus-article-button-face))
4801   (gnus-add-text-properties
4802    from to
4803    (nconc (and gnus-article-mouse-face
4804                (list gnus-mouse-face-prop gnus-article-mouse-face))
4805           (list 'gnus-callback fun)
4806           (and data (list 'gnus-data data)))))
4807
4808 ;;; Internal functions:
4809
4810 (defun gnus-article-set-globals ()
4811   (save-excursion
4812     (set-buffer gnus-summary-buffer)
4813     (gnus-set-global-variables)))
4814
4815 (defun gnus-signature-toggle (end)
4816   (save-excursion
4817     (set-buffer gnus-article-buffer)
4818     (let ((buffer-read-only nil)
4819           (inhibit-point-motion-hooks t)
4820           (limit (next-single-property-change end 'mime-view-entity
4821                                               nil (point-max))))
4822       (if (get-text-property end 'invisible)
4823           (gnus-article-unhide-text end limit)
4824         (gnus-article-hide-text end limit gnus-hidden-properties)))))
4825
4826 (defun gnus-button-entry ()
4827   ;; Return the first entry in `gnus-button-alist' matching this place.
4828   (let ((alist gnus-button-alist)
4829         (entry nil))
4830     (while alist
4831       (setq entry (pop alist))
4832       (if (looking-at (car entry))
4833           (setq alist nil)
4834         (setq entry nil)))
4835     entry))
4836
4837 (defun gnus-button-push (marker)
4838   ;; Push button starting at MARKER.
4839   (save-excursion
4840     (goto-char marker)
4841     (let* ((entry (gnus-button-entry))
4842            (inhibit-point-motion-hooks t)
4843            (fun (nth 3 entry))
4844            (args (mapcar (lambda (group)
4845                            (let ((string (match-string group)))
4846                              (gnus-set-text-properties
4847                               0 (length string) nil string)
4848                              string))
4849                          (nthcdr 4 entry))))
4850       (cond
4851        ((fboundp fun)
4852         (apply fun args))
4853        ((and (boundp fun)
4854              (fboundp (symbol-value fun)))
4855         (apply (symbol-value fun) args))
4856        (t
4857         (gnus-message 1 "You must define `%S' to use this button"
4858                       (cons fun args)))))))
4859
4860 (defun gnus-button-message-id (message-id)
4861   "Fetch MESSAGE-ID."
4862   (save-excursion
4863     (set-buffer gnus-summary-buffer)
4864     (gnus-summary-refer-article message-id)))
4865
4866 (defun gnus-button-fetch-group (address)
4867   "Fetch GROUP specified by ADDRESS."
4868   (if (not (string-match "[:/]" address))
4869       ;; This is just a simple group url.
4870       (gnus-group-read-ephemeral-group address gnus-select-method)
4871     (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
4872                            address))
4873         (error "Can't parse %s" address)
4874       (gnus-group-read-ephemeral-group
4875        (match-string 4 address)
4876        `(nntp ,(match-string 1 address)
4877               (nntp-address ,(match-string 1 address))
4878               (nntp-port-number ,(if (match-end 3)
4879                                      (match-string 3 address)
4880                                    "nntp")))))))
4881
4882 (defun gnus-url-parse-query-string (query &optional downcase)
4883   (let (retval pairs cur key val)
4884     (setq pairs (split-string query "&"))
4885     (while pairs
4886       (setq cur (car pairs)
4887             pairs (cdr pairs))
4888       (if (not (string-match "=" cur))
4889           nil                           ; Grace
4890         (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
4891               val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
4892         (if downcase
4893             (setq key (downcase key)))
4894         (setq cur (assoc key retval))
4895         (if cur
4896             (setcdr cur (cons val (cdr cur)))
4897           (setq retval (cons (list key val) retval)))))
4898     retval))
4899
4900 (defun gnus-url-unhex (x)
4901   (if (> x ?9)
4902       (if (>= x ?a)
4903           (+ 10 (- x ?a))
4904         (+ 10 (- x ?A)))
4905     (- x ?0)))
4906
4907 (defun gnus-url-unhex-string (str &optional allow-newlines)
4908   "Remove %XXX embedded spaces, etc in a url.
4909 If optional second argument ALLOW-NEWLINES is non-nil, then allow the
4910 decoding of carriage returns and line feeds in the string, which is normally
4911 forbidden in URL encoding."
4912   (setq str (or str ""))
4913   (let ((tmp "")
4914         (case-fold-search t))
4915     (while (string-match "%[0-9a-f][0-9a-f]" str)
4916       (let* ((start (match-beginning 0))
4917              (ch1 (gnus-url-unhex (elt str (+ start 1))))
4918              (code (+ (* 16 ch1)
4919                       (gnus-url-unhex (elt str (+ start 2))))))
4920         (setq tmp (concat
4921                    tmp (substring str 0 start)
4922                    (cond
4923                     (allow-newlines
4924                      (char-to-string code))
4925                     ((or (= code ?\n) (= code ?\r))
4926                      " ")
4927                     (t (char-to-string code))))
4928               str (substring str (match-end 0)))))
4929     (setq tmp (concat tmp str))
4930     tmp))
4931
4932 (defun gnus-url-mailto (url)
4933   ;; Send mail to someone
4934   (when (string-match "mailto:/*\\(.*\\)" url)
4935     (setq url (substring url (match-beginning 1) nil)))
4936   (let (to args subject func)
4937     (if (string-match (regexp-quote "?") url)
4938         (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
4939               args (gnus-url-parse-query-string
4940                     (substring url (match-end 0) nil) t))
4941       (setq to (gnus-url-unhex-string url)))
4942     (setq args (cons (list "to" to) args)
4943           subject (cdr-safe (assoc "subject" args)))
4944     (gnus-setup-message 'reply
4945       (message-mail)
4946       (while args
4947         (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
4948         (if (fboundp func)
4949             (funcall func)
4950           (message-position-on-field (caar args)))
4951         (insert (mapconcat 'identity (cdar args) ", "))
4952         (setq args (cdr args)))
4953       (if subject
4954           (message-goto-body)
4955         (message-goto-subject)))))
4956
4957 (defun gnus-button-mailto (address)
4958   ;; Mail to ADDRESS.
4959   (set-buffer (gnus-copy-article-buffer))
4960   (gnus-setup-message 'reply
4961     (message-reply address)))
4962
4963 (defun gnus-button-reply (address)
4964   ;; Reply to ADDRESS.
4965   (gnus-setup-message 'reply
4966     (message-reply address)))
4967
4968 (defun gnus-button-embedded-url (address)
4969   "Browse ADDRESS."
4970   (browse-url (gnus-strip-whitespace address)))
4971
4972 (defun gnus-article-smiley-display ()
4973   "Display \"smileys\" as small graphical icons."
4974   (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max)))
4975
4976 ;;; Next/prev buttons in the article buffer.
4977
4978 (defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
4979 (defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
4980
4981 (defvar gnus-prev-page-map nil)
4982 (unless gnus-prev-page-map
4983   (setq gnus-prev-page-map (make-sparse-keymap))
4984   (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
4985   (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
4986
4987 (static-if (featurep 'xemacs)
4988     (defun gnus-insert-prev-page-button ()
4989       (let ((buffer-read-only nil))
4990         (gnus-eval-format
4991          gnus-prev-page-line-format nil
4992          `(gnus-prev t local-map ,gnus-prev-page-map
4993                      gnus-callback gnus-article-button-prev-page
4994                      article-type annotation))))
4995   (defun gnus-insert-prev-page-button ()
4996     (let ((buffer-read-only nil)
4997           (situation (get-text-property (point-min) 'mime-view-situation)))
4998       (set-keymap-parent gnus-prev-page-map (current-local-map))
4999       (gnus-eval-format
5000        gnus-prev-page-line-format nil
5001        `(gnus-prev t local-map ,gnus-prev-page-map
5002                    gnus-callback gnus-article-button-prev-page
5003                    article-type annotation
5004                    mime-view-situation ,situation))))
5005   )
5006
5007 (defvar gnus-next-page-map nil)
5008 (unless gnus-next-page-map
5009   (setq gnus-next-page-map (make-sparse-keymap))
5010   (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
5011   (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
5012
5013 (defun gnus-button-next-page ()
5014   "Go to the next page."
5015   (interactive)
5016   (let ((win (selected-window)))
5017     (select-window (get-buffer-window gnus-article-buffer t))
5018     (gnus-article-next-page)
5019     (select-window win)))
5020
5021 (defun gnus-button-prev-page ()
5022   "Go to the prev page."
5023   (interactive)
5024   (let ((win (selected-window)))
5025     (select-window (get-buffer-window gnus-article-buffer t))
5026     (gnus-article-prev-page)
5027     (select-window win)))
5028
5029 (static-if (featurep 'xemacs)
5030     (defun gnus-insert-next-page-button ()
5031       (let ((buffer-read-only nil))
5032         (gnus-eval-format gnus-next-page-line-format nil
5033                           `(gnus-next
5034                             t local-map ,gnus-next-page-map
5035                             gnus-callback gnus-article-button-next-page
5036                             article-type annotation))))
5037   (defun gnus-insert-next-page-button ()
5038     (let ((buffer-read-only nil)
5039           (situation (get-text-property (point-min) 'mime-view-situation)))
5040       (set-keymap-parent gnus-next-page-map (current-local-map))
5041       (gnus-eval-format gnus-next-page-line-format nil
5042                         `(gnus-next
5043                           t local-map ,gnus-next-page-map
5044                           gnus-callback gnus-article-button-next-page
5045                           article-type annotation
5046                           mime-view-situation ,situation))))
5047   )
5048
5049 (defun gnus-article-button-next-page (arg)
5050   "Go to the next page."
5051   (interactive "P")
5052   (let ((win (selected-window)))
5053     (select-window (get-buffer-window gnus-article-buffer t))
5054     (gnus-article-next-page)
5055     (select-window win)))
5056
5057 (defun gnus-article-button-prev-page (arg)
5058   "Go to the prev page."
5059   (interactive "P")
5060   (let ((win (selected-window)))
5061     (select-window (get-buffer-window gnus-article-buffer t))
5062     (gnus-article-prev-page)
5063     (select-window win)))
5064
5065 (defvar gnus-decode-header-methods
5066   '(mail-decode-encoded-word-region)
5067   "List of methods used to decode headers.
5068
5069 This variable is a list of FUNCTION or (REGEXP . FUNCTION).  If item
5070 is FUNCTION, FUNCTION will be apply to all newsgroups.  If item is a
5071 (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
5072 whose names match REGEXP.
5073
5074 For example:
5075 ((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
5076  mail-decode-encoded-word-region
5077  (\"chinese\" . rfc1843-decode-region))
5078 ")
5079
5080 (defvar gnus-decode-header-methods-cache nil)
5081
5082 (defun gnus-multi-decode-header (start end)
5083   "Apply the functions from `gnus-encoded-word-methods' that match."
5084   (unless (and gnus-decode-header-methods-cache
5085                (eq gnus-newsgroup-name
5086                    (car gnus-decode-header-methods-cache)))
5087     (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
5088     (mapcar (lambda (x)
5089               (if (symbolp x)
5090                   (nconc gnus-decode-header-methods-cache (list x))
5091                 (if (and gnus-newsgroup-name
5092                          (string-match (car x) gnus-newsgroup-name))
5093                     (nconc gnus-decode-header-methods-cache
5094                            (list (cdr x))))))
5095           gnus-decode-header-methods))
5096   (let ((xlist gnus-decode-header-methods-cache))
5097     (pop xlist)
5098     (save-restriction
5099       (narrow-to-region start end)
5100       (while xlist
5101         (funcall (pop xlist) (point-min) (point-max))))))
5102
5103 ;;;
5104 ;;; Treatment top-level handling.
5105 ;;;
5106
5107 (defun gnus-treat-article (condition &optional part-number total-parts type)
5108   (let ((length (- (point-max) (point-min)))
5109         (alist gnus-treatment-function-alist)
5110         (article-goto-body-goes-to-point-min-p t)
5111         (treated-type
5112          (or (not type)
5113              (catch 'found
5114                (let ((list gnus-article-treat-types))
5115                  (while list
5116                    (when (string-match (pop list) type)
5117                      (throw 'found t)))))))
5118         (highlightp (gnus-visual-p 'article-highlight 'highlight))
5119         (entity (static-unless (featurep 'xemacs)
5120                   (when (eq 'head condition)
5121                     (get-text-property (point-min) 'mime-view-entity))))
5122         val elem buttonized)
5123     (gnus-run-hooks 'gnus-part-display-hook)
5124     (unless gnus-inhibit-treatment
5125       (while (setq elem (pop alist))
5126         (with-current-buffer gnus-summary-buffer
5127           (setq val (symbol-value (car elem))))
5128         (when (and (or (consp val)
5129                        treated-type)
5130                    (gnus-treat-predicate val)
5131                    (or (not (get (car elem) 'highlight))
5132                        highlightp))
5133           (when (and (not buttonized)
5134                      (memq (car elem)
5135                            '(gnus-treat-hide-signature
5136                              gnus-treat-highlight-signature)))
5137             (gnus-article-buttonize-signature)
5138             (setq buttonized t))
5139           (save-restriction
5140             (funcall (cadr elem)))))
5141       ;; FSF Emacsen does not inherit the existing text properties
5142       ;; in the new text, so we should do it for `mime-view-entity'.
5143       (static-unless (featurep 'xemacs)
5144         (when entity
5145           (put-text-property (point-min) (point-max)
5146                              'mime-view-entity entity))))))
5147
5148 ;; Dynamic variables.
5149 (defvar part-number)
5150 (defvar total-parts)
5151 (defvar type)
5152 (defvar condition)
5153 (defvar length)
5154 (defun gnus-treat-predicate (val)
5155   (cond
5156    ((null val)
5157     nil)
5158    ((and (listp val)
5159          (stringp (car val)))
5160     (apply 'gnus-or (mapcar `(lambda (s)
5161                                (string-match s ,(or gnus-newsgroup-name "")))
5162                             val)))
5163    ((listp val)
5164     (let ((pred (pop val)))
5165       (cond
5166        ((eq pred 'or)
5167         (apply 'gnus-or (mapcar 'gnus-treat-predicate val)))
5168        ((eq pred 'and)
5169         (apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
5170        ((eq pred 'not)
5171         (not (gnus-treat-predicate (car val))))
5172        ((eq pred 'typep)
5173         (equal (car val) type))
5174        (t
5175         (error "%S is not a valid predicate" pred)))))
5176    ((eq val 'mime)
5177     gnus-show-mime)
5178    (condition
5179     (eq condition val))
5180    ((eq val t)
5181     t)
5182    ((eq val 'head)
5183     nil)
5184    ((eq val 'last)
5185     (eq part-number total-parts))
5186    ((numberp val)
5187     (< length val))
5188    (t
5189     (error "%S is not a valid value" val))))
5190
5191
5192 ;;; @ for mime-view
5193 ;;;
5194
5195 (defun gnus-article-header-presentation-method (entity situation)
5196   (mime-insert-header entity)
5197   )
5198
5199 (set-alist 'mime-header-presentation-method-alist
5200            'gnus-original-article-mode
5201            #'gnus-article-header-presentation-method)
5202
5203 (defun gnus-mime-preview-quitting-method ()
5204   (mime-preview-kill-buffer)
5205   (delete-other-windows)
5206   (gnus-article-show-summary)
5207   (gnus-summary-select-article gnus-show-all-headers t))
5208
5209 (set-alist 'mime-preview-quitting-method-alist
5210            'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
5211
5212 (set-alist 'mime-preview-following-method-alist
5213            'gnus-original-article-mode #'gnus-following-method)
5214
5215 (set-alist 'mime-preview-over-to-previous-method-alist
5216            'gnus-original-article-mode
5217            (lambda ()
5218              (if (> (point-min) 1)
5219                  (gnus-article-prev-page)
5220                (gnus-article-read-summary-keys
5221                 nil (gnus-character-to-event ?P)))))
5222
5223 (set-alist 'mime-preview-over-to-next-method-alist
5224            'gnus-original-article-mode'
5225            (lambda ()
5226              (if (< (point-max) (buffer-size))
5227                  (gnus-article-next-page)
5228                (gnus-article-read-summary-keys
5229                 nil (gnus-character-to-event ?N)))))
5230
5231
5232 ;;; @ end
5233 ;;;
5234
5235 (gnus-ems-redefine)
5236
5237 (provide 'gnus-art)
5238
5239 (run-hooks 'gnus-art-load-hook)
5240
5241 ;;; gnus-art.el ends here