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

   1 ;;; gnus-art.el --- article mode commands for Gnus
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; For Emacs < 22.2.
  29 (eval-and-compile
  30   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  31 (eval-when-compile
  32   (require 'cl))
  33 (defvar tool-bar-map)
  34 (defvar w3m-minor-mode-map)
  35
  36 (require 'gnus)
  37 ;; Avoid the "Recursive load suspected" error in Emacs 21.1.
  38 (eval-and-compile
  39   (let ((recursive-load-depth-limit 100))
  40     (require 'gnus-sum)))
  41 (require 'gnus-spec)
  42 (require 'gnus-int)
  43 (require 'gnus-win)
  44 (require 'mm-bodies)
  45 (require 'mail-parse)
  46 (require 'mm-decode)
  47 (require 'mm-view)
  48 (require 'wid-edit)
  49 (require 'mm-uu)
  50 (require 'message)
  51
  52 (autoload 'gnus-msg-mail "gnus-msg" nil t)
  53 (autoload 'gnus-button-mailto "gnus-msg")
  54 (autoload 'gnus-button-reply "gnus-msg" nil t)
  55 (autoload 'parse-time-string "parse-time" nil nil)
  56 (autoload 'ansi-color-apply-on-region "ansi-color")
  57 (autoload 'mm-url-insert-file-contents-external "mm-url")
  58 (autoload 'mm-extern-cache-contents "mm-extern")
  59
  60 (defgroup gnus-article nil
  61   "Article display."
  62   :link '(custom-manual "(gnus)Article Buffer")
  63   :group 'gnus)
  64
  65 (defgroup gnus-article-treat nil
  66   "Treating article parts."
  67   :link '(custom-manual "(gnus)Article Hiding")
  68   :group 'gnus-article)
  69
  70 (defgroup gnus-article-hiding nil
  71   "Hiding article parts."
  72   :link '(custom-manual "(gnus)Article Hiding")
  73   :group 'gnus-article)
  74
  75 (defgroup gnus-article-highlight nil
  76   "Article highlighting."
  77   :link '(custom-manual "(gnus)Article Highlighting")
  78   :group 'gnus-article
  79   :group 'gnus-visual)
  80
  81 (defgroup gnus-article-signature nil
  82   "Article signatures."
  83   :link '(custom-manual "(gnus)Article Signature")
  84   :group 'gnus-article)
  85
  86 (defgroup gnus-article-headers nil
  87   "Article headers."
  88   :link '(custom-manual "(gnus)Hiding Headers")
  89   :group 'gnus-article)
  90
  91 (defgroup gnus-article-washing nil
  92   "Special commands on articles."
  93   :link '(custom-manual "(gnus)Article Washing")
  94   :group 'gnus-article)
  95
  96 (defgroup gnus-article-emphasis nil
  97   "Fontisizing articles."
  98   :link '(custom-manual "(gnus)Article Fontisizing")
  99   :group 'gnus-article)
 100
 101 (defgroup gnus-article-saving nil
 102   "Saving articles."
 103   :link '(custom-manual "(gnus)Saving Articles")
 104   :group 'gnus-article)
 105
 106 (defgroup gnus-article-mime nil
 107   "Worshiping the MIME wonder."
 108   :link '(custom-manual "(gnus)Using MIME")
 109   :group 'gnus-article)
 110
 111 (defgroup gnus-article-buttons nil
 112   "Pushable buttons in the article buffer."
 113   :link '(custom-manual "(gnus)Article Buttons")
 114   :group 'gnus-article)
 115
 116 (defgroup gnus-article-various nil
 117   "Other article options."
 118   :link '(custom-manual "(gnus)Misc Article")
 119   :group 'gnus-article)
 120
 121 (defcustom gnus-ignored-headers
 122   (mapcar
 123    (lambda (header)
 124      (concat "^" header ":"))
 125    '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
 126      "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
 127      "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
 128      "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
 129      "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
 130      "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
 131      "X-Attribution" "X-Originating-IP" "Delivered-To"
 132      "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
 133      "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
 134      "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
 135      "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
 136      "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
 137      "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
 138      "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
 139      "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
 140      "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
 141      "MBOX-Line" "Priority" "X400-[-A-Za-z]+"
 142      "Status" "X-Gnus-Mail-Source" "Cancel-Lock"
 143      "X-FTN" "X-EXP32-SerialNo" "Encoding" "Importance"
 144      "Autoforwarded" "Original-Encoded-Information-Types" "X-Ya-Pop3"
 145      "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
 146      "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
 147      "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
 148      "List-[A-Za-z]+" "X-Listprocessor-Version"
 149      "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
 150      "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
 151      "X-Received" "Content-length" "X-precedence"
 152      "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
 153      "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
 154      "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
 155      "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
 156      "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
 157      "X-Content-length" "X-Posting-Agent" "Original-Received"
 158      "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
 159      "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
 160      "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
 161      "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
 162      "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"
 163      "Envelope-To" "X-Spam-Score" "System-Type" "X-Injected-Via-Gmane"
 164      "X-Gmane-NNTP-Posting-Host" "Jabber-ID" "Archived-At"
 165      "Envelope-Sender" "Envelope-Recipients"))
 166   "*All headers that start with this regexp will be hidden.
 167 This variable can also be a list of regexps of headers to be ignored.
 168 If `gnus-visible-headers' is non-nil, this variable will be ignored."
 169   :type '(choice :custom-show nil
 170                  regexp
 171                  (repeat regexp))
 172   :group 'gnus-article-hiding)
 173
 174 (defcustom gnus-visible-headers
 175   "^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:"
 176   "*All headers that do not match this regexp will be hidden.
 177 This variable can also be a list of regexp of headers to remain visible.
 178 If this variable is non-nil, `gnus-ignored-headers' will be ignored."
 179   :type '(choice
 180           (repeat :value-to-internal (lambda (widget value)
 181                                        (custom-split-regexp-maybe value))
 182                   :match (lambda (widget value)
 183                            (or (stringp value)
 184                                (widget-editable-list-match widget value)))
 185                   regexp)
 186           (const :tag "Use gnus-ignored-headers" nil)
 187           regexp)
 188   :group 'gnus-article-hiding)
 189
 190 (defcustom gnus-sorted-header-list
 191   '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:"
 192     "^Followup-To:" "^To:" "^Cc:" "^Date:" "^Organization:")
 193   "*This variable is a list of regular expressions.
 194 If it is non-nil, headers that match the regular expressions will
 195 be placed first in the article buffer in the sequence specified by
 196 this list."
 197   :type '(repeat regexp)
 198   :group 'gnus-article-hiding)
 199
 200 (defcustom gnus-boring-article-headers '(empty followup-to reply-to)
 201   "Headers that are only to be displayed if they have interesting data.
 202 Possible values in this list are:
 203
 204   'empty       Headers with no content.
 205   'newsgroups  Newsgroup identical to Gnus group.
 206   'to-address  To identical to To-address.
 207   'to-list     To identical to To-list.
 208   'cc-list     CC identical to To-list.
 209   'followup-to Followup-to identical to Newsgroups.
 210   'reply-to    Reply-to identical to From.
 211   'date        Date less than four days old.
 212   'long-to     To and/or Cc longer than 1024 characters.
 213   'many-to     Multiple To and/or Cc."
 214   :type '(set (const :tag "Headers with no content." empty)
 215               (const :tag "Newsgroups identical to Gnus group." newsgroups)
 216               (const :tag "To identical to To-address." to-address)
 217               (const :tag "To identical to To-list." to-list)
 218               (const :tag "CC identical to To-list." cc-list)
 219               (const :tag "Followup-to identical to Newsgroups." followup-to)
 220               (const :tag "Reply-to identical to From." reply-to)
 221               (const :tag "Date less than four days old." date)
 222               (const :tag "To and/or Cc longer than 1024 characters." long-to)
 223               (const :tag "Multiple To and/or Cc headers." many-to))
 224   :group 'gnus-article-hiding)
 225
 226 (defcustom gnus-article-skip-boring nil
 227   "Skip over text that is not worth reading.
 228 By default, if you set this t, then Gnus will display citations and
 229 signatures, but will never scroll down to show you a page consisting
 230 only of boring text.  Boring text is controlled by
 231 `gnus-article-boring-faces'."
 232   :version "22.1"
 233   :type 'boolean
 234   :group 'gnus-article-hiding)
 235
 236 (defcustom gnus-signature-separator '("^-- $" "^-- *$")
 237   "Regexp matching signature separator.
 238 This can also be a list of regexps.  In that case, it will be checked
 239 from head to tail looking for a separator.  Searches will be done from
 240 the end of the buffer."
 241   :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
 242                  (regexp)
 243                  (repeat :tag "List of regexp" regexp))
 244   :group 'gnus-article-signature)
 245
 246 (defcustom gnus-signature-limit nil
 247   "Provide a limit to what is considered a signature.
 248 If it is a number, no signature may not be longer (in characters) than
 249 that number.  If it is a floating point number, no signature may be
 250 longer (in lines) than that number.  If it is a function, the function
 251 will be called without any parameters, and if it returns nil, there is
 252 no signature in the buffer.  If it is a string, it will be used as a
 253 regexp.  If it matches, the text in question is not a signature.
 254
 255 This can also be a list of the above values."
 256   :type '(choice (const nil)
 257                  (integer :value 200)
 258                  (number :value 4.0)
 259                  function
 260                  (regexp :value ".*"))
 261   :group 'gnus-article-signature)
 262
 263 (defcustom gnus-hidden-properties '(invisible t intangible t)
 264   "Property list to use for hiding text."
 265   :type 'sexp
 266   :group 'gnus-article-hiding)
 267
 268 ;; Fixme: This isn't the right thing for mixed graphical and non-graphical
 269 ;; frames in a session.
 270 (defcustom gnus-article-x-face-command
 271   (if (featurep 'xemacs)
 272       (if (or (gnus-image-type-available-p 'xface)
 273               (gnus-image-type-available-p 'pbm))
 274           'gnus-display-x-face-in-from
 275         "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
 276     (if (gnus-image-type-available-p 'pbm)
 277         'gnus-display-x-face-in-from
 278       "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
 279 display -"))
 280   "*String or function to be executed to display an X-Face header.
 281 If it is a string, the command will be executed in a sub-shell
 282 asynchronously.  The compressed face will be piped to this command."
 283   :type `(choice string
 284                  (function-item gnus-display-x-face-in-from)
 285                  function)
 286   :version "21.1"
 287   :group 'gnus-picon
 288   :group 'gnus-article-washing)
 289
 290 (defcustom gnus-article-x-face-too-ugly nil
 291   "Regexp matching posters whose face shouldn't be shown automatically."
 292   :type '(choice regexp (const nil))
 293   :group 'gnus-article-washing)
 294
 295 (defcustom gnus-article-banner-alist nil
 296   "Banner alist for stripping.
 297 For example,
 298      ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
 299   :version "21.1"
 300   :type '(repeat (cons symbol regexp))
 301   :group 'gnus-article-washing)
 302
 303 (gnus-define-group-parameter
 304  banner
 305  :variable-document
 306  "Alist of regexps (to match group names) and banner."
 307  :variable-group gnus-article-washing
 308  :parameter-type
 309  '(choice :tag "Banner"
 310           :value nil
 311           (const :tag "Remove signature" signature)
 312           (symbol :tag "Item in `gnus-article-banner-alist'" none)
 313           regexp
 314           (const :tag "None" nil))
 315  :parameter-document
 316  "If non-nil, specify how to remove `banners' from articles.
 317
 318 Symbol `signature' means to remove signatures delimited by
 319 `gnus-signature-separator'.  Any other symbol is used to look up a
 320 regular expression to match the banner in `gnus-article-banner-alist'.
 321 A string is used as a regular expression to match the banner
 322 directly.")
 323
 324 (defcustom gnus-article-address-banner-alist nil
 325   "Alist of mail addresses and banners.
 326 Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
 327 to match a mail address in the From: header, BANNER is one of a symbol
 328 `signature', an item in `gnus-article-banner-alist', a regexp and nil.
 329 If ADDRESS matches author's mail address, it will remove things like
 330 advertisements.  For example:
 331
 332 \((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
 333 "
 334   :type '(repeat
 335           (cons
 336            (regexp :tag "Address")
 337            (choice :tag "Banner" :value nil
 338                    (const :tag "Remove signature" signature)
 339                    (symbol :tag "Item in `gnus-article-banner-alist'" none)
 340                    regexp
 341                    (const :tag "None" nil))))
 342   :version "22.1"
 343   :group 'gnus-article-washing)
 344
 345 (defmacro gnus-emphasis-custom-with-format (&rest body)
 346   `(let ((format "\
 347 \\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
 348 \\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
 349      ,@body))
 350
 351 (defun gnus-emphasis-custom-value-to-external (value)
 352   (gnus-emphasis-custom-with-format
 353    (if (consp (car value))
 354        (list (format format (car (car value)) (cdr (car value)))
 355              2
 356              (if (nth 1 value) 2 3)
 357              (nth 2 value))
 358      value)))
 359
 360 (defun gnus-emphasis-custom-value-to-internal (value)
 361   (gnus-emphasis-custom-with-format
 362    (let ((regexp (concat "\\`"
 363                          (format (regexp-quote format)
 364                                  "\\([^()]+\\)" "\\([^()]+\\)")
 365                          "\\'"))
 366          pattern)
 367      (if (string-match regexp (setq pattern (car value)))
 368          (list (cons (match-string 1 pattern) (match-string 2 pattern))
 369                (= (nth 2 value) 2)
 370                (nth 3 value))
 371        value))))
 372
 373 (defcustom gnus-emphasis-alist
 374   (let ((types
 375          '(("\\*" "\\*" bold nil 2)
 376            ("_" "_" underline)
 377            ("/" "/" italic)
 378            ("_/" "/_" underline-italic)
 379            ("_\\*" "\\*_" underline-bold)
 380            ("\\*/" "/\\*" bold-italic)
 381            ("_\\*/" "/\\*_" underline-bold-italic))))
 382     (nconc
 383      (gnus-emphasis-custom-with-format
 384       (mapcar (lambda (spec)
 385                 (list (format format (car spec) (cadr spec))
 386                       (or (nth 3 spec) 2)
 387                       (or (nth 4 spec) 3)
 388                       (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
 389               types))
 390      '(;; I've never seen anyone use this strikethru convention whereas I've
 391        ;; several times seen it triggered by normal text.  --Stef
 392        ;; Miles suggests that this form is sometimes used but for italics,
 393        ;; so maybe we should map it to `italic'.
 394        ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
 395        ;; 2 3 gnus-emphasis-strikethru)
 396        ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
 397         2 3 gnus-emphasis-underline))))
 398   "*Alist that says how to fontify certain phrases.
 399 Each item looks like this:
 400
 401   (\"_\\\\(\\\\w+\\\\)_\" 0 1 'underline)
 402
 403 The first element is a regular expression to be matched.  The second
 404 is a number that says what regular expression grouping used to find
 405 the entire emphasized word.  The third is a number that says what
 406 regexp grouping should be displayed and highlighted.  The fourth
 407 is the face used for highlighting."
 408   :type
 409   '(repeat
 410     (menu-choice
 411      :format "%[Customizing Style%]\n%v"
 412      :indent 2
 413      (group :tag "Default"
 414             :value ("" 0 0 default)
 415             :value-create
 416             (lambda (widget)
 417               (let ((value (widget-get
 418                             (cadr (widget-get (widget-get widget :parent)
 419                                               :args))
 420                             :value)))
 421                 (if (not (eq (nth 2 value) 'default))
 422                     (widget-put
 423                      widget
 424                      :value
 425                      (gnus-emphasis-custom-value-to-external value))))
 426               (widget-group-value-create widget))
 427             regexp
 428             (integer :format "Match group: %v")
 429             (integer :format "Emphasize group: %v")
 430             face)
 431      (group :tag "Simple"
 432             :value (("_" . "_") nil default)
 433             (cons :format "%v"
 434                   (regexp :format "S