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