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

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