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

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