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

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