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

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