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

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