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

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