cgit.sxemacs.org Git - gnus/blob - lisp/gnus-art.el

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