;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; For Emacs <22.2 and XEmacs.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
- (require 'cl)
- (defvar tool-bar-map)
- (defvar w3m-minor-mode-map))
+ (require 'cl))
+(defvar tool-bar-map)
+(defvar w3m-minor-mode-map)
(require 'gnus)
-;; Avoid the "Recursive load suspected" error in Emacs 21.1.
-(eval-and-compile
- (let ((recursive-load-depth-limit 100))
- (require 'gnus-sum)))
+(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
(require 'gnus-win)
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "^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:"
+ "^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:"
"*All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
- :type '(repeat :value-to-internal (lambda (widget value)
- (custom-split-regexp-maybe value))
- :match (lambda (widget value)
- (or (stringp value)
- (widget-editable-list-match widget value)))
- regexp)
+ :type '(choice
+ (repeat :value-to-internal (lambda (widget value)
+ (custom-split-regexp-maybe value))
+ :match (lambda (widget value)
+ (or (stringp value)
+ (widget-editable-list-match widget value)))
+ regexp)
+ (const :tag "Use gnus-ignored-headers" nil)
+ regexp)
:group 'gnus-article-hiding)
(defcustom gnus-sorted-header-list
:group 'gnus-article-saving
:type 'regexp)
+;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before.
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
"A function to save articles in your favourite format.
The function will be called by way of the `gnus-summary-save-article'
* gnus-summary-save-in-vm (use VM's folder format)
* gnus-summary-write-to-file (article format -- overwrite)
* gnus-summary-write-body-to-file (article body -- overwrite)
+* gnus-summary-save-in-pipe (article format)
The symbol of each function may have the following properties:
* :decode
The value non-nil means save decoded articles. This is meaningful
only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
-`gnus-summary-write-to-file', and `gnus-summary-write-body-to-file'.
+`gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and
+`gnus-summary-save-in-pipe'.
* :function
The value specifies an alternative function which appends, not
(function-item gnus-summary-save-in-vm)
(function-item gnus-summary-write-to-file)
(function-item gnus-summary-write-body-to-file)
+ (function-item gnus-summary-save-in-pipe)
(function)))
(defcustom gnus-article-save-coding-system
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
%w The article washing status.
%m The number of MIME parts in the article."
+ :version "24.1"
:type 'string
:group 'gnus-article-various)
(defcustom gnus-copy-article-ignored-headers nil
"List of headers to be removed when copying an article.
Each element is a regular expression."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:type '(repeat regexp)
:group 'gnus-article-various)
-(make-obsolete-variable 'gnus-article-hide-pgp-hook
- "This variable is obsolete in Gnus 5.10.")
+(make-obsolete-variable 'gnus-article-hide-pgp-hook nil
+ "Gnus 5.10 (Emacs 22.1)")
(defface gnus-button
'((t (:weight bold)))
:group 'gnus-article-signature)
;; backward-compatibility alias
(put 'gnus-signature-face 'face-alias 'gnus-signature)
+(put 'gnus-signature-face 'obsolete-face "22.1")
(defface gnus-header-from
'((((class color)
:group 'gnus-article-highlight)
;; backward-compatibility alias
(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
+(put 'gnus-header-from-face 'obsolete-face "22.1")
(defface gnus-header-subject
'((((class color)
:group 'gnus-article-highlight)
;; backward-compatibility alias
(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
+(put 'gnus-header-subject-face 'obsolete-face "22.1")
(defface gnus-header-newsgroups
'((((class color)
:group 'gnus-article-highlight)
;; backward-compatibility alias
(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
+(put 'gnus-header-newsgroups-face 'obsolete-face "22.1")
(defface gnus-header-name
'((((class color)
:group 'gnus-article-highlight)
;; backward-compatibility alias
(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
+(put 'gnus-header-name-face 'obsolete-face "22.1")
(defface gnus-header-content
'((((class color)
:group 'gnus-article-highlight)
;; backward-compatibility alias
(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
+(put 'gnus-header-content-face 'obsolete-face "22.1")
(defcustom gnus-header-face-alist
'(("From" nil gnus-header-from)
Currently, `pbm' is used for X-Face images and `png' is used for Face
images in Emacs. Only the `:face' property is effective on the `xface'
image type in XEmacs if it is built with the libcompface library."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:group 'gnus-article-headers
:type '(repeat (cons :format "%v" (symbol :tag "Image type") plist)))
"Function used to decode addresses.")
(defvar gnus-article-dumbquotes-map
- '(("\200" "EUR")
- ("\202" ",")
- ("\203" "f")
- ("\204" ",,")
- ("\205" "...")
- ("\213" "<")
- ("\214" "OE")
- ("\221" "`")
- ("\222" "'")
- ("\223" "``")
- ("\224" "\"")
- ("\225" "*")
- ("\226" "-")
- ("\227" "--")
- ("\230" "~")
- ("\231" "(TM)")
- ("\233" ">")
- ("\234" "oe")
- ("\264" "'"))
+ '((?\200 "EUR")
+ (?\202 ",")
+ (?\203 "f")
+ (?\204 ",,")
+ (?\205 "...")
+ (?\213 "<")
+ (?\214 "OE")
+ (?\221 "`")
+ (?\222 "'")
+ (?\223 "``")
+ (?\224 "\"")
+ (?\225 "*")
+ (?\226 "-")
+ (?\227 "--")
+ (?\230 "~")
+ (?\231 "(TM)")
+ (?\233 ">")
+ (?\234 "oe")
+ (?\264 "'"))
"Table for MS-to-Latin1 translation.")
(defcustom gnus-ignored-mime-types nil
:group 'gnus-article-mime
:type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
-(defcustom gnus-article-date-lapsed-new-header nil
- "Whether the X-Sent and Date headers can coexist.
-When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
-either replace the old \"Date:\" header (if this variable is nil), or
-be added below it (otherwise)."
- :version "21.1"
+(defcustom gnus-article-date-headers '(combined-lapsed)
+ "A list of Date header formats to display.
+Valid formats are `ut' (universal time), `local' (local time
+zone), `english' (readable English), `lapsed' (elapsed time),
+`combined-lapsed' (both the original date and the elapsed time),
+`original' (the original date header), `iso8601' (ISO8601
+format), and `user-defined' (a user-defined format defined by the
+`gnus-article-time-format' variable).
+
+You have as many date headers as you want in the article buffer.
+Some of these headers are updated automatically. See
+`gnus-article-update-date-headers' for details."
+ :version "24.1"
:group 'gnus-article-headers
- :type 'boolean)
+ :type '(repeat
+ (item :tag "Universal time (UT)" :value 'ut)
+ (item :tag "Local time zone" :value 'local)
+ (item :tag "Readable English" :value 'english)
+ (item :tag "Elapsed time" :value 'lapsed)
+ (item :tag "Original and elapsed time" :value 'combined-lapsed)
+ (item :tag "Original date header" :value 'original)
+ (item :tag "ISO8601 format" :value 'iso8601)
+ (item :tag "User-defined" :value 'user-defined)))
+
+(defcustom gnus-article-update-date-headers 1
+ "How often to update the date header.
+If nil, don't update it at all."
+ :version "24.1"
+ :group 'gnus-article-headers
+ :type '(choice
+ (item :tag "Don't update" :value nil)
+ integer))
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
When 0, point will be placed on the same part as before. When
positive (negative), move point forward (backwards) this many
parts. When nil, redisplay article."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:group 'gnus-article-mime
:type '(choice (const nil :tag "Redisplay article.")
(const 1 :tag "Next part.")
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize
- (and (or window-system
- (featurep 'xemacs))
- 50000)
+(defcustom gnus-treat-date 'head
+ "Display dates according to the `gnus-article-date-headers' variable.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-head-custom)
+
+(defcustom gnus-treat-emphasize 50000
"Emphasize text.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(make-obsolete-variable 'gnus-treat-strip-pgp
- "This option is obsolete in Gnus 5.10.")
+(make-obsolete-variable 'gnus-treat-strip-pgp nil
+ "Gnus 5.10 (Emacs 22.1)")
(defcustom gnus-treat-strip-pem nil
"Strip PEM signatures.
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-citation 'highlight t)
-(defcustom gnus-treat-date-ut nil
- "Display the Date in UT (GMT).
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-local nil
- "Display the Date in the local timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-english nil
- "Display the Date in a format that can be read aloud in English.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "22.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-lapsed nil
- "Display the Date header in a way that says how much time has elapsed.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-original nil
- "Display the date in the original timezone.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-iso8601 nil
- "Display the date in the ISO8601 format.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
-(defcustom gnus-treat-date-user-defined nil
- "Display the date in a user-defined format.
-The format is defined by the `gnus-article-time-format' variable.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-head-custom)
-
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `first', `last', an integer or a
If it is t, all long headers are unfolded.
This variable has no effect if `gnus-treat-unfold-headers' is nil."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:group 'gnus-article-treat
:type '(choice (const nil)
(const :tag "all" t)
:type gnus-article-treat-custom)
(make-obsolete-variable 'gnus-treat-display-xface
- 'gnus-treat-display-x-face)
+ 'gnus-treat-display-x-face "Emacs 22.1")
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
(gnus-image-type-available-p 'xbm)
(if (featurep 'xemacs)
(featurep 'xface)
- (and (string-match "^0x" (shell-command-to-string "uncompface"))
- (executable-find "icontopbm")))
+ (condition-case nil
+ (and (string-match "^0x" (shell-command-to-string "uncompface"))
+ (executable-find "icontopbm"))
+ ;; shell-command-to-string may signal an error, e.g. if
+ ;; shell-file-name is not found.
+ (error nil)))
'head)
"Display X-Face headers.
Valid values are nil and `head'.
"Display Face headers.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles' and Info
-node `(gnus)X-Face' for details."
+node `(gnus)Face' for details."
:group 'gnus-article-treat
:version "22.1"
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(put 'gnus-treat-newsgroups-picon 'highlight t)
+(defcustom gnus-treat-from-gravatar nil
+ "Display gravatars in the From header.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-gravatar 'highlight t)
+
+(defcustom gnus-treat-mail-gravatar nil
+ "Display gravatars in To and Cc headers.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles' and Info
+node `(gnus)Gravatars' for details."
+ :version "24.1"
+ :group 'gnus-article-treat
+ :group 'gnus-gravatar
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Gravatars")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-gravatar 'highlight t)
+
(defcustom gnus-treat-body-boundary
- (if (and (eq window-system 'x)
- (or gnus-treat-newsgroups-picon
- gnus-treat-mail-picon
- gnus-treat-from-picon))
- 'head nil)
+ (if (or gnus-treat-newsgroups-picon
+ gnus-treat-mail-picon
+ gnus-treat-from-picon
+ gnus-treat-from-gravatar
+ gnus-treat-mail-gravatar)
+ ;; If there's much decoration, the user might prefer a boundery.
+ 'head
+ nil)
"Draw a boundary at the end of the headers.
Valid values are nil and `head'.
See Info node `(gnus)Customizing Articles' for details."
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-fill-long-lines nil
+(defcustom gnus-treat-fill-long-lines '(typep "text/plain")
"Fill long lines.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-custom)
-
-(defcustom gnus-treat-play-sounds nil
- "Play sounds.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
- :group 'gnus-article-treat
- :link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-custom)
-
-(defcustom gnus-treat-translate nil
- "Translate articles from one language to another.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles'."
- :version "21.1"
+ :version "24.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:type 'string
:group 'mime-security)
-(defvar gnus-article-wash-function nil
- "Function used for converting HTML into text.")
-
(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
(mm-coding-system-p 'utf-8)
(executable-find idna-program))
:group 'gnus-article
:type 'boolean)
+(defcustom gnus-inhibit-images nil
+ "Non-nil means inhibit displaying of images inline in the article body."
+ :version "24.1"
+ :group 'gnus-article
+ :type 'boolean)
+
+(defcustom gnus-blocked-images 'gnus-block-private-groups
+ "Images that have URLs matching this regexp will be blocked.
+This can also be a function to be evaluated. If so, it will be
+called with the group name as the parameter, and should return a
+regexp."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'regexp)
+
;;; Internal variables
(defvar gnus-english-month-names
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
- (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
+ (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
(gnus-treat-unsplit-urls gnus-article-unsplit-urls)
- (gnus-treat-date-ut gnus-article-date-ut)
- (gnus-treat-date-local gnus-article-date-local)
- (gnus-treat-date-english gnus-article-date-english)
- (gnus-treat-date-original gnus-article-date-original)
- (gnus-treat-date-user-defined gnus-article-date-user)
- (gnus-treat-date-iso8601 gnus-article-date-iso8601)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-hide-signature gnus-article-hide-signature)
(gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
(gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
- (gnus-treat-strip-pem gnus-article-hide-pem)
(gnus-treat-from-picon gnus-treat-from-picon)
(gnus-treat-mail-picon gnus-treat-mail-picon)
(gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
+ (gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-date gnus-article-treat-date)
+ (gnus-treat-from-gravatar gnus-treat-from-gravatar)
+ (gnus-treat-mail-gravatar gnus-treat-mail-gravatar)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-strip-trailing-blank-lines
(gnus-treat-hide-citation gnus-article-hide-citation)
(gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
(gnus-treat-highlight-citation gnus-article-highlight-citation)
- (gnus-treat-body-boundary gnus-article-treat-body-boundary)
- (gnus-treat-play-sounds gnus-earcon-display)))
+ (gnus-treat-body-boundary gnus-article-treat-body-boundary)))
(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(defvar gnus-save-article-buffer nil)
-(defvar gnus-article-mode-line-format-alist
- (nconc '((?w (gnus-article-wash-status) ?s)
- (?m (gnus-article-mime-part-status) ?s))
- gnus-summary-mode-line-format-alist))
-
(defvar gnus-number-of-articles-to-be-saved nil)
(defvar gnus-inhibit-hiding nil)
;;; Macros for dealing with the article buffer.
(defmacro gnus-with-article-headers (&rest forms)
- `(save-excursion
- (set-buffer gnus-article-buffer)
+ `(with-current-buffer gnus-article-buffer
(save-restriction
(let ((inhibit-read-only t)
(inhibit-point-motion-hooks t)
(put 'gnus-with-article-headers 'edebug-form-spec '(body))
(defmacro gnus-with-article-buffer (&rest forms)
- `(save-excursion
- (set-buffer gnus-article-buffer)
+ `(with-current-buffer gnus-article-buffer
(let ((inhibit-read-only t))
,@forms)))
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
+(defvar org-entities)
+
+(defun article-treat-non-ascii ()
+ "Translate many Unicode characters into their ASCII equivalents."
+ (interactive)
+ (require 'org-entities)
+ (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
+ (dolist (elem org-entities)
+ (when (and (listp elem)
+ (= (length (nth 6 elem)) 1))
+ (if (featurep 'xemacs)
+ (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
+ (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t)
+ replace props)
+ (while (not (eobp))
+ (if (not (setq replace (if (featurep 'xemacs)
+ (get-char-table (following-char) table)
+ (aref table (following-char)))))
+ (forward-char 1)
+ (if (prog1
+ (setq props (text-properties-at (point)))
+ (delete-char 1))
+ (add-text-properties (point) (progn (insert replace) (point))
+ props)
+ (insert replace)))))))))
+
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
FROM is a string of characters to translate from; to is a string of
(when (article-goto-body)
(let ((inhibit-read-only t))
(dolist (elem map)
- (save-excursion
- (while (search-forward (car elem) nil t)
- (replace-match (cadr elem)))))))))
+ (let ((from (car elem))
+ (to (cadr elem)))
+ (save-excursion
+ (if (stringp from)
+ (while (search-forward from nil t)
+ (replace-match to))
+ (while (not (eobp))
+ (if (eq (following-char) from)
+ (progn
+ (delete-char 1)
+ (insert to))
+ (forward-char 1)))))))))))
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
"Remove all images from the article buffer."
(interactive)
(gnus-with-article-buffer
- (dolist (elem gnus-article-image-alist)
- (gnus-delete-images (car elem)))))
+ (save-restriction
+ (widen)
+ (dolist (elem gnus-article-image-alist)
+ (gnus-delete-images (car elem))))))
+
+(defun gnus-article-show-images ()
+ "Show any images that are in the HTML-rendered article buffer.
+This only works if the article in question is HTML."
+ (interactive)
+ (gnus-with-article-buffer
+ (save-restriction
+ (widen)
+ (dolist (region (gnus-find-text-property-region (point-min) (point-max)
+ 'image-displayer))
+ (destructuring-bind (start end function) region
+ (funcall function (get-text-property start 'image-url)
+ start end))))))
(defun gnus-article-treat-fold-newsgroups ()
"Unfold folded message headers.
(mail-header-fold-field)
(goto-char (point-max))))))
-(defcustom gnus-article-truncate-lines default-truncate-lines
+(defcustom gnus-article-truncate-lines (default-value 'truncate-lines)
"Value of `truncate-lines' in Gnus Article buffer.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:group 'gnus-article
;; :link '(custom-manual "(gnus)Customizing Articles")
:type 'boolean)
"Toggle whether to fold or truncate long lines in article the buffer.
If ARG is non-nil and not a number, toggle
`gnus-article-truncate-lines' too. If ARG is a number, truncate
-long lines iff arg is positive."
+long lines if and only if arg is positive."
(interactive "P")
(cond
((and (numberp arg) (> arg 0))
(insert "X-Boundary: ")
(gnus-add-text-properties start (point) '(invisible t intangible t))
(insert (let (str)
- (while (>= (1- (window-width)) (length str))
+ (while (>= (window-width) (length str))
(setq str (concat str gnus-body-boundary-delimiter)))
- (substring str 0 (1- (window-width))))
+ (substring str 0 (window-width)))
"\n")
(gnus-put-text-property start (point) 'gnus-decoration 'header)))))
(forward-line 1)
(point))))))
-(eval-when-compile
- (defvar gnus-face-properties-alist))
+(defvar gnus-face-properties-alist)
-(defun article-display-face ()
+(defun article-display-face (&optional force)
"Display any Face headers in the header."
- (interactive)
+ (interactive (list 'force))
(let ((wash-face-p buffer-read-only))
(gnus-with-article-headers
;; When displaying parts, this function can be called several times on
;; read-only.
(if (and wash-face-p (memq 'face gnus-article-wash-types))
(gnus-delete-images 'face)
- (let (face faces from)
+ (let ((from (message-fetch-field "from"))
+ face faces)
(save-current-buffer
(when (and wash-face-p
(gnus-buffer-live-p gnus-original-article-buffer)
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
- (while (gnus-article-goto-header "Face")
- (push (mail-header-field-value) faces))))
+ (when (or force
+ ;; Check whether this face is censored.
+ (not (and gnus-article-x-face-too-ugly
+ (or from
+ (setq from (message-fetch-field "from")))
+ (string-match gnus-article-x-face-too-ugly
+ from))))
+ (while (gnus-article-goto-header "Face")
+ (push (mail-header-field-value) faces)))))
(when faces
(goto-char (point-min))
- (let ((from (gnus-article-goto-header "from"))
- png image)
- (unless from
+ (let (png image)
+ (unless (setq from (gnus-article-goto-header "from"))
(insert "From:")
(setq from (point))
- (insert "[no `from' set]\n"))
+ (insert " [no `from' set]\n"))
(while faces
(when (setq png (gnus-convert-face-to-png (pop faces)))
(setq image
;; instead.
(gnus-delete-images 'xface)
;; Display X-Faces.
- (let (x-faces from face)
+ (let ((from (message-fetch-field "from"))
+ x-faces face)
(save-current-buffer
(when (and wash-face-p
(gnus-buffer-live-p gnus-original-article-buffer)
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
- (while (gnus-article-goto-header "X-Face")
- (push (mail-header-field-value) x-faces))
- (setq from (message-fetch-field "from"))))
- ;; Sending multiple EOFs to xv doesn't work, so we only do a
- ;; single external face.
- (when (stringp gnus-article-x-face-command)
- (setq x-faces (list (car x-faces))))
- (when (and x-faces
- gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and from
- (not (string-match gnus-article-x-face-too-ugly
- from)))))
- (while (setq face (pop x-faces))
- ;; We display the face.
- (cond ((stringp gnus-article-x-face-command)
- ;; The command is a string, so we interpret the command
- ;; as a, well, command, and fork it off.
- (let ((process-connection-type nil))
- (gnus-set-process-query-on-exit-flag
- (start-process
- "article-x-face" nil shell-file-name
- shell-command-switch gnus-article-x-face-command)
- nil)
- (with-temp-buffer
- (insert face)
- (process-send-region "article-x-face"
- (point-min) (point-max)))
- (process-send-eof "article-x-face")))
- ((functionp gnus-article-x-face-command)
- ;; The command is a lisp function, so we call it.
- (funcall gnus-article-x-face-command face))
- (t
- (error "%s is not a function"
- gnus-article-x-face-command))))))))))
+ (and gnus-article-x-face-command
+ (or force
+ ;; Check whether this face is censored.
+ (not (and gnus-article-x-face-too-ugly
+ (or from
+ (setq from (message-fetch-field "from")))
+ (string-match gnus-article-x-face-too-ugly
+ from))))
+ (while (gnus-article-goto-header "X-Face")
+ (push (mail-header-field-value) x-faces)))))
+ (when x-faces
+ ;; We display the face.
+ (cond ((functionp gnus-article-x-face-command)
+ ;; The command is a lisp function, so we call it.
+ (mapc gnus-article-x-face-command x-faces))
+ ((stringp gnus-article-x-face-command)
+ ;; The command is a string, so we interpret the command
+ ;; as a, well, command, and fork it off.
+ (let ((process-connection-type nil))
+ (gnus-set-process-query-on-exit-flag
+ (start-process
+ "article-x-face" nil shell-file-name
+ shell-command-switch gnus-article-x-face-command)
+ nil)
+ ;; Sending multiple EOFs to xv doesn't work,
+ ;; so we only do a single external face.
+ (with-temp-buffer
+ (insert (car x-faces))
+ (process-send-region "article-x-face"
+ (point-min) (point-max)))
+ (process-send-eof "article-x-face")))
+ (t
+ (error "`%s' set to `%s' is not a function"
+ gnus-article-x-face-command
+ 'gnus-article-x-face-command)))))))))
(defun article-decode-mime-words ()
"Decode all MIME-encoded words in the article."
(when (interactive-p)
(gnus-treat-article nil))))
-
-(defun article-wash-html (&optional read-charset)
- "Format an HTML article.
-If READ-CHARSET, ask for a coding system. If it is a number, the
-charset defined in `gnus-summary-show-article-charset-alist' is used."
- (interactive "P")
- (save-excursion
- (let ((inhibit-read-only t)
- charset)
- (if read-charset
- (if (or (and (numberp read-charset)
- (setq charset
- (cdr
- (assq read-charset
- gnus-summary-show-article-charset-alist))))
- (setq charset (mm-read-coding-system "Charset: ")))
- (let ((gnus-summary-show-article-charset-alist
- (list (cons 1 charset))))
- (with-current-buffer gnus-summary-buffer
- (gnus-summary-show-article 1)))
- (error "No charset is given"))
- (when (gnus-buffer-live-p gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct (mail-header-parse-content-type ct))))
- (setq charset (and ctl
- (mail-content-type-get ctl 'charset)))
- (when (stringp charset)
- (setq charset (intern (downcase charset)))))))
- (unless charset
- (setq charset gnus-newsgroup-charset)))
- (article-goto-body)
- (save-window-excursion
- (save-restriction
- (narrow-to-region (point) (point-max))
- (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
- (entry (assq func mm-text-html-washer-alist)))
- (when entry
- (setq func (cdr entry)))
- (cond
- ((functionp func)
- (funcall func))
- (t
- (apply (car func) (cdr func))))))))))
-
-(defun gnus-article-wash-html-with-w3 ()
- "Wash the current buffer with w3."
- (mm-setup-w3)
- (let ((w3-strict-width (window-width))
- (url-standalone-mode t)
- (url-gateway-unplugged t)
- (w3-honor-stylesheets nil))
- (condition-case ()
- (w3-region (point-min) (point-max))
- (error))))
-
-(defun gnus-article-wash-html-with-w3m ()
- "Wash the current buffer with emacs-w3m."
- (mm-setup-w3m)
- (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
- w3m-force-redisplay)
- (w3m-region (point-min) (point-max)))
- (when (and mm-inline-text-html-with-w3m-keymap
- (boundp 'w3m-minor-mode-map)
- w3m-minor-mode-map)
- (add-text-properties
- (point-min) (point-max)
- (list 'keymap w3m-minor-mode-map
- ;; Put the mark meaning this part was rendered by emacs-w3m.
- 'mm-inline-text-html-with-w3m t))))
-
-(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'.
-
-(defun gnus-article-wash-html-with-w3m-standalone ()
- "Wash the current buffer with w3m."
- (if (mm-w3m-standalone-supports-m17n-p)
- (progn
- (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
- ;; The default.
- (setq charset 'iso-8859-1))
- (let ((coding-system-for-write charset)
- (coding-system-for-read charset))
- (call-process-region
- (point-min) (point-max)
- "w3m" t t nil "-dump" "-T" "text/html"
- "-I" (symbol-name charset) "-O" (symbol-name charset))))
- (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
+(defun article-wash-html ()
+ "Format an HTML article."
+ (interactive)
+ (let ((handles nil)
+ (buffer-read-only nil))
+ (when (gnus-buffer-live-p gnus-original-article-buffer)
+ (setq handles (mm-dissect-buffer t t)))
+ (article-goto-body)
+ (delete-region (point) (point-max))
+ (mm-inline-text-html handles)))
(defvar gnus-article-browse-html-temp-list nil
"List of temporary files created by `gnus-article-browse-html-parts'.
on each file, if it is `ask' ask once when exiting from the
summary buffer."
:group 'gnus-article
- :version "23.0" ;; No Gnus
+ :version "23.1" ;; No Gnus
:type '(choice (const :tag "Don't delete" nil)
(const :tag "Don't ask" t)
(const :tag "Ask" ask)
(defun gnus-article-browse-delete-temp-files (&optional how)
"Delete temp-files created by `gnus-article-browse-html-parts'."
(when (and gnus-article-browse-html-temp-list
- (or how
- (setq how gnus-article-browse-delete-temp)))
- (when (and (eq how 'ask)
- (y-or-n-p (format
- "Delete all %s temporary HTML file(s)? "
- (length gnus-article-browse-html-temp-list)))
- (setq how t)))
+ (progn
+ (or how (setq how gnus-article-browse-delete-temp))
+ (if (eq how 'ask)
+ (let ((files (length gnus-article-browse-html-temp-list)))
+ (gnus-y-or-n-p (format
+ "Delete all %s temporary HTML file%s? "
+ files
+ (if (> files 1) "s" ""))))
+ how)))
(dolist (file gnus-article-browse-html-temp-list)
- (when (and (file-exists-p file)
- (or (eq how t)
- ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'):
- (gnus-y-or-n-p
- (format "Delete temporary HTML file `%s'? " file))))
- (delete-file file)))
+ (cond ((file-directory-p file)
+ (when (or (not (eq how 'file))
+ (gnus-y-or-n-p
+ (format
+ "Delete temporary HTML file(s) in directory `%s'? "
+ (file-name-as-directory file))))
+ (gnus-delete-directory file)))
+ ((file-exists-p file)
+ (when (or (not (eq how 'file))
+ (gnus-y-or-n-p
+ (format "Delete temporary HTML file `%s'? " file)))
+ (delete-file file)))))
;; Also remove file from the list when not deleted or if file doesn't
;; exist anymore.
(setq gnus-article-browse-html-temp-list nil))
gnus-article-browse-html-temp-list)
-(defun gnus-article-browse-html-parts (list)
+(defun gnus-article-browse-html-save-cid-content (cid handles directory)
+ "Find CID content in HANDLES and save it in a file in DIRECTORY.
+Return file name."
+ (save-match-data
+ (let (file type)
+ (catch 'found
+ (dolist (handle handles)
+ (cond
+ ((not (listp handle)))
+ ((equal (mm-handle-media-supertype handle) "multipart")
+ (when (setq file (gnus-article-browse-html-save-cid-content
+ cid handle directory))
+ (throw 'found file)))
+ ((equal (concat "<" cid ">") (mm-handle-id handle))
+ (setq file
+ (expand-file-name
+ (or (mail-content-type-get
+ (mm-handle-disposition handle) 'filename)
+ (mail-content-type-get
+ (setq type (mm-handle-type handle)) 'name)
+ (concat
+ (make-temp-name "cid")
+ (car (rassoc (car type) mailcap-mime-extensions))))
+ directory))
+ (mm-save-part-to-file handle file)
+ (throw 'found file))))))))
+
+(defun gnus-article-browse-html-parts (list &optional header)
"View all \"text/html\" parts from LIST.
-Recurse into multiparts."
+Recurse into multiparts. The optional HEADER that should be a decoded
+message header will be added to the bodies of the \"text/html\" parts."
;; Internal function used by `gnus-article-browse-html-article'.
- (let ((showed))
+ (let (type file charset content cid-dir tmp-file showed)
;; Find and show the html-parts.
(dolist (handle list)
;; If HTML, show it:
- (when (listp handle)
- (cond ((and (bufferp (car handle))
- (string-match "text/html" (car (mm-handle-type handle))))
- (let ((tmp-file (mm-make-temp-file
- ;; Do we need to care for 8.3 filenames?
- "mm-" nil ".html")))
- (mm-save-part-to-file handle tmp-file)
- (add-to-list 'gnus-article-browse-html-temp-list tmp-file)
- (add-hook 'gnus-summary-prepare-exit-hook
- 'gnus-article-browse-delete-temp-files)
- (add-hook 'gnus-exit-gnus-hook
- (lambda ()
- (gnus-article-browse-delete-temp-files t)))
- ;; FIXME: Warn if there's an <img> tag?
- (browse-url-of-file tmp-file)
- (setq showed t)))
- ;; If multipart, recurse
- ((and (stringp (car handle))
- (string-match "^multipart/" (car handle))
- (setq showed
- (or showed
- (gnus-article-browse-html-parts handle))))))))
+ (cond ((not (listp handle)))
+ ((or (equal (car (setq type (mm-handle-type handle))) "text/html")
+ (and (equal (car type) "message/external-body")
+ (or header
+ (setq file (or (mail-content-type-get type 'name)
+ (mail-content-type-get
+ (mm-handle-disposition handle)
+ 'filename))))
+ (or (mm-handle-cache handle)
+ (condition-case code
+ (progn (mm-extern-cache-contents handle) t)
+ (error
+ (gnus-message 3 "%s" (error-message-string code))
+ (when (>= gnus-verbose 3) (sit-for 2))
+ nil)))
+ (progn
+ (setq handle (mm-handle-cache handle)
+ type (mm-handle-type handle))
+ (equal (car type) "text/html"))))
+ (setq charset (mail-content-type-get type 'charset)
+ content (mm-get-part handle))
+ (with-temp-buffer
+ (if (eq charset 'gnus-decoded)
+ (mm-enable-multibyte)
+ (mm-disable-multibyte))
+ (insert content)
+ ;; resolve cid contents
+ (let ((case-fold-search t)
+ cid-file)
+ (goto-char (point-min))
+ (while (re-search-forward "\
+<img[\t\n ]+\\(?:[^\t\n >]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\""
+ nil t)
+ (unless cid-dir
+ (setq cid-dir (mm-make-temp-file "cid" t))
+ (add-to-list 'gnus-article-browse-html-temp-list cid-dir))
+ (setq file nil
+ content nil)
+ (when (setq cid-file
+ (gnus-article-browse-html-save-cid-content
+ (match-string 2)
+ (with-current-buffer gnus-article-buffer
+ gnus-article-mime-handles)
+ cid-dir))
+ (replace-match (concat "file://" cid-file)
+ nil nil nil 1))))
+ (unless content (setq content (buffer-string))))
+ (when (or charset header (not file))
+ (setq tmp-file (mm-make-temp-file
+ ;; Do we need to care for 8.3 filenames?
+ "mm-" nil ".html")))
+ ;; Add a meta html tag to specify charset and a header.
+ (cond
+ (header
+ (let (title eheader body hcharset coding force-charset)
+ (with-temp-buffer
+ (mm-enable-multibyte)
+ (setq case-fold-search t)
+ (insert header "\n")
+ (setq title (message-fetch-field "subject"))
+ (goto-char (point-min))
+ (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t)
+ (replace-match (cond ((match-beginning 1) "<")
+ ((match-beginning 2) ">")
+ (t "&"))))
+ (goto-char (point-min))
+ (insert "<pre>\n")
+ (goto-char (point-max))
+ (insert "</pre>\n<hr>\n")
+ ;; We have to examine charset one by one since
+ ;; charset specified in parts might be different.
+ (if (eq charset 'gnus-decoded)
+ (setq charset 'utf-8
+ eheader (mm-encode-coding-string (buffer-string)
+ charset)
+ title (when title
+ (mm-encode-coding-string title charset))
+ body (mm-encode-coding-string content charset)
+ force-charset t)
+ (setq hcharset (mm-find-mime-charset-region (point-min)
+ (point-max)))
+ (cond ((= (length hcharset) 1)
+ (setq hcharset (car hcharset)
+ coding (mm-charset-to-coding-system
+ hcharset)))
+ ((> (length hcharset) 1)
+ (setq hcharset 'utf-8
+ coding hcharset)))
+ (if coding
+ (if charset
+ (progn
+ (setq body
+ (mm-charset-to-coding-system charset))
+ (if (eq coding body)
+ (setq eheader (mm-encode-coding-string
+ (buffer-string) coding)
+ title (when title
+ (mm-encode-coding-string
+ title coding))
+ body content)
+ (setq charset 'utf-8
+ eheader (mm-encode-coding-string
+ (buffer-string) charset)
+ title (when title
+ (mm-encode-coding-string
+ title charset))
+ body (mm-encode-coding-string
+ (mm-decode-coding-string
+ content body)
+ charset)
+ force-charset t)))
+ (setq charset hcharset
+ eheader (mm-encode-coding-string
+ (buffer-string) coding)
+ title (when title
+ (mm-encode-coding-string
+ title coding))
+ body content))
+ (setq eheader (mm-string-as-unibyte (buffer-string))
+ body content)))
+ (erase-buffer)
+ (mm-disable-multibyte)
+ (insert body)
+ (when charset
+ (mm-add-meta-html-tag handle charset force-charset))
+ (when title
+ (goto-char (point-min))
+ (unless (search-forward "<title>" nil t)
+ (re-search-forward "<head>\\s-*" nil t)
+ (insert "<title>" title "</title>\n")))
+ (goto-char (point-min))
+ (or (re-search-forward
+ "<body\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
+ (re-search-forward
+ "</head\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t))
+ (insert eheader)
+ (mm-write-region (point-min) (point-max)
+ tmp-file nil nil nil 'binary t))))
+ (charset
+ (mm-with-unibyte-buffer
+ (insert (if (eq charset 'gnus-decoded)
+ (mm-encode-coding-string content
+ (setq charset 'utf-8))
+ content))
+ (if (or (mm-add-meta-html-tag handle charset)
+ (not file))
+ (mm-write-region (point-min) (point-max)
+ tmp-file nil nil nil 'binary t)
+ (setq tmp-file nil))))
+ (tmp-file
+ (mm-save-part-to-file handle tmp-file)))
+ (when tmp-file
+ (add-to-list 'gnus-article-browse-html-temp-list tmp-file))
+ (add-hook 'gnus-summary-prepare-exit-hook
+ 'gnus-article-browse-delete-temp-files)
+ (add-hook 'gnus-exit-gnus-hook
+ (lambda ()
+ (gnus-article-browse-delete-temp-files t)))
+ ;; FIXME: Warn if there's an <img> tag?
+ (browse-url-of-file (or tmp-file (expand-file-name file)))
+ (setq showed t))
+ ;; If multipart, recurse
+ ((equal (mm-handle-media-supertype handle) "multipart")
+ (when (gnus-article-browse-html-parts handle header)
+ (setq showed t)))
+ ((equal (mm-handle-media-type handle) "message/rfc822")
+ (mm-with-multibyte-buffer
+ (mm-insert-part handle)
+ (setq handle (mm-dissect-buffer t t))
+ (when (and (bufferp (car handle))
+ (stringp (car (mm-handle-type handle))))
+ (setq handle (list handle)))
+ (when header
+ (article-decode-encoded-words)
+ (let ((gnus-visible-headers
+ (or (get 'gnus-visible-headers 'standard-value)
+ gnus-visible-headers)))
+ (article-hide-headers))
+ (goto-char (point-min))
+ (search-forward "\n\n" nil 'move)
+ (skip-chars-backward "\t\n ")
+ (setq header (buffer-substring (point-min) (point)))))
+ (when (prog1
+ (gnus-article-browse-html-parts handle header)
+ (mm-destroy-parts handle))
+ (setq showed t)))))
showed))
-;; FIXME: Documentation in texi/gnus.texi missing.
-(defun gnus-article-browse-html-article ()
+(defun gnus-article-browse-html-article (&optional arg)
"View \"text/html\" parts of the current article with a WWW browser.
-
-Warning: Spammers use links to images in HTML articles to verify
-whether you have read the message. As
-`gnus-article-browse-html-article' passes the unmodified HTML
-content to the browser without eliminating these \"web bugs\" you
-should only use it for mails from trusted senders."
+Inline images embedded in a message using the cid scheme, as they are
+generally considered to be safe, will be processed properly.
+The message header is added to the beginning of every html part unless
+the prefix argument ARG is given.
+
+Warning: Spammers use links to images (using the http scheme) in HTML
+articles to verify whether you have read the message. As
+`gnus-article-browse-html-article' passes the HTML content to the
+browser without eliminating these \"web bugs\" you should only
+use it for mails from trusted senders.
+
+If you always want to display HTML parts in the browser, set
+`mm-text-html-renderer' to nil.
+
+This command creates temporary files to pass HTML contents including
+images if any to the browser, and deletes them when exiting the group
+\(if you want)."
;; Cf. `mm-w3m-safe-url-regexp'
- (interactive)
- (save-window-excursion
- ;; Open raw article and select the buffer
- (gnus-summary-show-article t)
- (gnus-summary-select-article-buffer)
- (let ((parts (mm-dissect-buffer t t)))
+ (interactive "P")
+ (if arg
+ (gnus-summary-show-article)
+ (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value)
+ gnus-visible-headers))
+ ;; As we insert a <hr>, there's no need for the body boundary.
+ (gnus-treat-body-boundary nil))
+ (gnus-summary-show-article)))
+ (with-current-buffer gnus-article-buffer
+ (let ((header (unless arg
+ (save-restriction
+ (widen)
+ (buffer-substring-no-properties
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (match-beginning 0)
+ (goto-char (point-max))
+ (skip-chars-backward "\t\n ")
+ (point))))))
+ parts)
+ (set-buffer gnus-original-article-buffer)
+ (setq parts (mm-dissect-buffer t t))
;; If singlepart, enforce a list.
(when (and (bufferp (car parts))
(stringp (car (mm-handle-type parts))))
(setq parts (list parts)))
;; Process the list
- (unless (gnus-article-browse-html-parts parts)
+ (unless (gnus-article-browse-html-parts parts header)
(gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
- (gnus-summary-show-article))))
+ (mm-destroy-parts parts)
+ (unless arg
+ (gnus-summary-show-article)))))
(defun article-hide-list-identifiers ()
"Remove list identifies from the Subject header.
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight)
- "Convert DATE date to universal time in the current article.
-If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE. For `lapsed', the value of
-`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
-should replace the \"Date:\" one, or should be added below it."
+(defun article-treat-date ()
+ (article-date-ut gnus-article-date-headers t))
+
+(defun article-date-ut (&optional type highlight date-position)
+ "Convert DATE date to TYPE in the current article.
+The default type is `ut'. See `gnus-article-date-headers' for
+possible values."
(interactive (list 'ut t))
- (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (article-lapsed-timer
- "^Date:[ \t]")
- (t
- tdate-regexp)))
- (case-fold-search t)
+ (let* ((case-fold-search t)
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
+ (first t)
pos date bface eface)
(save-excursion
(save-restriction
- (widen)
(goto-char (point-min))
- (while (or (setq date (get-text-property (setq pos (point))
- 'original-date))
- (when (setq pos (next-single-property-change
- (point) 'original-date))
- (setq date (get-text-property pos 'original-date))
- t))
- (narrow-to-region pos (or (text-property-any pos (point-max)
- 'original-date nil)
- (point-max)))
- (goto-char (point-min))
- (when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- eface (get-text-property (1- (point-at-eol)) 'face)))
- (goto-char (point-min))
- (setq pos nil)
- ;; Delete any old Date headers.
- (while (re-search-forward date-regexp nil t)
- (if pos
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (point)))
- (delete-region (point-at-bol) (progn
- (gnus-article-forward-header)
- (forward-char -1)
- (point)))
- (setq pos (point))))
- (when (and (not pos)
- (re-search-forward tdate-regexp nil t))
- (forward-line 1))
- (gnus-goto-char pos)
- (insert (article-make-date-line date (or type 'ut)))
- (unless pos
- (insert "\n")
- (forward-line -1))
- ;; Do highlighting.
- (beginning-of-line)
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))
- (put-text-property (point-min) (1- (point-max)) 'original-date date)
- (goto-char (point-max))
- (widen))))))
+ (when (re-search-forward "^Date:" nil t)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (point-at-eol)) 'face)))
+ (goto-char (point-min))
+ ;; Delete any old Date headers.
+ (if date-position
+ (progn
+ (goto-char date-position)
+ (setq date (get-text-property (point) 'original-date))
+ (delete-region (point)
+ (progn
+ (gnus-article-forward-header)
+ (point)))
+ (article-transform-date date type bface eface))
+ (while (re-search-forward "^Date:" nil t)
+ (setq date (get-text-property (match-beginning 0) 'original-date))
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (point))))
+ (when date
+ (article-transform-date date type bface eface)))))))
+
+(defun article-transform-date (date type bface eface)
+ (dolist (this-type (cond
+ ((null type)
+ (list 'ut))
+ ((atom type)
+ (list type))
+ (t
+ type)))
+ (insert (article-make-date-line date (or this-type 'ut)) "\n")
+ (forward-line -1)
+ (beginning-of-line)
+ (put-text-property (point) (1+ (point))
+ 'original-date date)
+ (put-text-property (point) (1+ (point))
+ 'gnus-date-type this-type)
+ ;; Do highlighting.
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'face eface))
+ (forward-line 1)))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (unless (memq type '(local ut original user iso8601 lapsed english))
+ (unless (memq type '(local ut original user-defined iso8601 lapsed english
+ combined-lapsed))
(error "Unknown conversion type: %s" type))
(condition-case ()
(let ((time (date-to-time date)))
(substring date 0 (match-beginning 0))
date)))
;; Let the user define the format.
- ((eq type 'user)
+ ((eq type 'user-defined)
(let ((format (or (condition-case nil
(with-current-buffer gnus-summary-buffer
gnus-article-time-format)
(format "%s%02d%02d"
(if (> tz 0) "+" "-") (/ (abs tz) 3600)
(/ (% (abs tz) 3600) 60)))))
- ;; Do an X-Sent lapsed format.
+ ;; Do a lapsed format.
((eq type 'lapsed)
- ;; If the date is seriously mangled, the timezone functions are
- ;; liable to bug out, so we ignore all errors.
- (let* ((now (current-time))
- (real-time (subtract-time now time))
- (real-sec (and real-time
- (+ (* (float (car real-time)) 65536)
- (cadr real-time))))
- (sec (and real-time (abs real-sec)))
- num prev)
- (cond
- ((null real-time)
- "X-Sent: Unknown")
- ((zerop sec)
- "X-Sent: Now")
- (t
- (concat
- "X-Sent: "
- ;; This is a bit convoluted, but basically we go
- ;; through the time units for years, weeks, etc,
- ;; and divide things to see whether that results
- ;; in positive answers.
- (mapconcat
- (lambda (unit)
- (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
- ;; The (remaining) seconds are too few to
- ;; be divided into this time unit.
- ""
- ;; It's big enough, so we output it.
- (setq sec (- sec (* num (cdr unit))))
- (prog1
- (concat (if prev ", " "") (int-to-string
- (floor num))
- " " (symbol-name (car unit))
- (if (> num 1) "s" ""))
- (setq prev t))))
- article-time-units "")
- ;; If dates are odd, then it might appear like the
- ;; article was sent in the future.
- (if (> real-sec 0)
- " ago"
- " in the future"))))))
+ (concat "Date: " (article-lapsed-string time)))
+ ;; A combined date/lapsed format.
+ ((eq type 'combined-lapsed)
+ (let ((date-string (article-make-date-line date 'original))
+ (segments 3)
+ lapsed-string)
+ (while (and
+ (setq lapsed-string
+ (concat " (" (article-lapsed-string time segments) ")"))
+ (> (+ (length date-string)
+ (length lapsed-string))
+ (+ fill-column 6))
+ (> segments 0))
+ (setq segments (1- segments)))
+ (if (> segments 0)
+ (concat date-string lapsed-string)
+ date-string)))
;; Display the date in proper English
((eq type 'english)
(let ((dtime (decode-time time)))
(format "%02d" (nth 2 dtime))
":"
(format "%02d" (nth 1 dtime)))))))
- (error
+ (foo
(format "Date: %s (from Gnus)" date))))
+(defun article-lapsed-string (time &optional max-segments)
+ ;; If the date is seriously mangled, the timezone functions are
+ ;; liable to bug out, so we ignore all errors.
+ (let* ((now (current-time))
+ (real-time (subtract-time now time))
+ (real-sec (and real-time
+ (+ (* (float (car real-time)) 65536)
+ (cadr real-time))))
+ (sec (and real-time (abs real-sec)))
+ (segments 0)
+ num prev)
+ (unless max-segments
+ (setq max-segments (length article-time-units)))
+ (cond
+ ((null real-time)
+ "Unknown")
+ ((zerop sec)
+ "Now")
+ (t
+ (concat
+ ;; This is a bit convoluted, but basically we go
+ ;; through the time units for years, weeks, etc,
+ ;; and divide things to see whether that results
+ ;; in positive answers.
+ (mapconcat
+ (lambda (unit)
+ (if (or (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ (>= segments max-segments))
+ ;; The (remaining) seconds are too few to
+ ;; be divided into this time unit.
+ ""
+ ;; It's big enough, so we output it.
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t
+ segments (1+ segments)))))
+ article-time-units "")
+ ;; If dates are odd, then it might appear like the
+ ;; article was sent in the future.
+ (if (> real-sec 0)
+ " ago"
+ " in the future"))))))
+
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(interactive (list t))
(interactive (list t))
(article-date-ut 'lapsed highlight))
+(defun article-date-combined-lapsed (&optional highlight)
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive (list t))
+ (article-date-ut 'combined-lapsed highlight))
+
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
(save-match-data
- (let (deactivate-mark)
- (save-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (let ((mark (point-marker)))
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))
- (goto-char (marker-position mark))
- (move-marker mark nil))))
- nil 'visible))))))
+ (let ((buffer (current-buffer)))
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (eq major-mode 'gnus-article-mode)
+ (let ((old-line (count-lines (point-min) (point)))
+ (old-column (- (point) (line-beginning-position)))
+ (window-start
+ (window-start (get-buffer-window (current-buffer)))))
+ (goto-char (point-min))
+ (while (re-search-forward "^Date:" nil t)
+ (let ((type (get-text-property (match-beginning 0)
+ 'gnus-date-type)))
+ (when (memq type '(lapsed combined-lapsed user-format))
+ (unless (= window-start
+ (save-excursion
+ (forward-line 1)
+ (point)))
+ (setq window-start nil))
+ (save-excursion
+ (article-date-ut type t (match-beginning 0)))
+ (forward-line 1)
+ (when window-start
+ (set-window-start (get-buffer-window (current-buffer))
+ (point))))))
+ (goto-char (point-min))
+ (when (> old-column 0)
+ (setq old-line (1- old-line)))
+ (forward-line old-line)
+ (end-of-line)
+ (when (> (current-column) old-column)
+ (beginning-of-line)
+ (forward-char old-column)))))
+ nil 'visible))
+ (set-buffer buffer))))
(defun gnus-start-date-timer (&optional n)
- "Start a timer to update the X-Sent header in the article buffers.
+ "Start a timer to update the Date headers in the article buffers.
The numerical prefix says how frequently (in seconds) the function
is to run."
(interactive "p")
(run-at-time 1 n 'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
- "Stop the X-Sent timer."
+ "Stop the Date timer."
(interactive)
(when article-lapsed-timer
(nnheader-cancel-timer article-lapsed-timer)
gnus-newsgroup-name 'highlight-words t)))
gnus-emphasis-alist)))))
-(eval-when-compile
- (defvar gnus-summary-article-menu)
- (defvar gnus-summary-post-menu))
+(defvar gnus-summary-article-menu)
+(defvar gnus-summary-post-menu)
;;; Saving functions.
(let ((gnus-visible-headers
(or (symbol-value (get gnus-default-article-saver :headers))
gnus-saved-headers gnus-visible-headers))
- (gnus-article-buffer save-buffer))
- (save-excursion
- (set-buffer save-buffer)
+ ;; Ignore group parameter. See `article-hide-headers'.
+ (gnus-summary-buffer nil))
+ (with-current-buffer save-buffer
(article-hide-headers 1 t))))
(save-window-excursion
(if (not gnus-default-article-saver)
"Save %s in rmail file" filename
gnus-rmail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-rmail))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
+ ;; Note that unlike gnus-summary-save-in-mail, there is no
+ ;; check to see if filename is Babyl. Rmail in Emacs 23 does
+ ;; not use Babyl.
(gnus-output-to-rmail filename))))
filename)
"Save %s in Unix mail file" filename
gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-mail))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
(if (and (file-readable-p filename)
(file-regular-p filename)
(mail-file-babyl-p filename))
- (rmail-output-to-rmail-file filename t)
+ (gnus-output-to-rmail filename)
(gnus-output-to-mail filename)))))
filename)
"Save %s in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
"Save %s body in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
- (gnus-eval-in-buffer-window gnus-save-article-buffer
+ (with-current-buffer gnus-save-article-buffer
(save-excursion
(save-restriction
(widen)
gnus-current-headers nil 'gnus-newsgroup-last-directory))
(gnus-summary-save-body-in-file filename t))
-(defun gnus-summary-save-in-pipe (&optional command)
- "Pipe this article to subprocess."
- (setq command
- (cond ((and (eq command 'default)
- gnus-last-shell-command)
- gnus-last-shell-command)
- ((stringp command)
- command)
- (t (read-string
- (format
- "Shell command on %s: "
- (if (and gnus-number-of-articles-to-be-saved
- (> gnus-number-of-articles-to-be-saved 1))
- (format "these %d articles"
- gnus-number-of-articles-to-be-saved)
- "this article"))
- gnus-last-shell-command))))
- (when (string-equal command "")
- (if gnus-last-shell-command
- (setq command gnus-last-shell-command)
- (error "A command is required")))
- (gnus-eval-in-buffer-window gnus-article-buffer
- (save-restriction
- (widen)
- (shell-command-on-region (point-min) (point-max) command nil)))
- (setq gnus-last-shell-command command))
+(put 'gnus-summary-save-in-pipe :decode t)
+(put 'gnus-summary-save-in-pipe :headers 'gnus-saved-headers)
+(defun gnus-summary-save-in-pipe (&optional command raw)
+ "Pipe this article to subprocess COMMAND.
+Valid values for COMMAND include:
+ a string
+ The executable command name and possibly arguments.
+ nil
+ You will be prompted for the command in the minibuffer.
+ the symbol `default'
+ It will be replaced with the command which the variable
+ `gnus-summary-pipe-output-default-command' holds or the command
+ last used for saving.
+Non-nil value for RAW overrides `:decode' and `:headers' properties
+and the raw article including all headers will be piped."
+ (let ((article (gnus-summary-article-number))
+ (decode (unless raw
+ (get 'gnus-summary-save-in-pipe :decode)))
+ save-buffer default)
+ (if article
+ (if (vectorp (gnus-summary-article-header article))
+ (save-current-buffer
+ (gnus-summary-select-article decode decode nil article)
+ (insert-buffer-substring
+ (prog1
+ (if decode
+ gnus-article-buffer
+ gnus-original-article-buffer)
+ (setq save-buffer
+ (nnheader-set-temp-buffer " *Gnus Save*"))))
+ ;; Remove unwanted headers.
+ (when (and (not raw)
+ (or (get 'gnus-summary-save-in-pipe :headers)
+ (not gnus-save-all-headers)))
+ (let ((gnus-visible-headers
+ (or (symbol-value (get 'gnus-summary-save-in-pipe
+ :headers))
+ gnus-saved-headers gnus-visible-headers))
+ (gnus-summary-buffer nil))
+ (article-hide-headers 1 t))))
+ (error "%d is not a real article" article))
+ (error "No article to pipe"))
+ (setq default (or gnus-summary-pipe-output-default-command
+ gnus-last-shell-command))
+ (unless (stringp command)
+ (setq command
+ (if (and (eq command 'default) default)
+ default
+ (gnus-read-shell-command "Shell command on this article: "
+ default))))
+ (when (string-equal command "")
+ (if default
+ (setq command default)
+ (error "A command is required")))
+ (with-current-buffer save-buffer
+ (save-restriction
+ (widen)
+ (shell-command-on-region (point-min) (point-max) command nil)))
+ (gnus-kill-buffer save-buffer))
+ (setq gnus-summary-pipe-output-default-command command))
(defun gnus-summary-pipe-to-muttprint (&optional command)
"Pipe this article to muttprint."
- (setq command (read-string
- "Print using command: " gnus-summary-muttprint-program
- nil gnus-summary-muttprint-program))
- (gnus-summary-save-in-pipe command))
+ (unless (stringp command)
+ (setq command (read-string
+ "Print using command: " gnus-summary-muttprint-program
+ nil gnus-summary-muttprint-program)))
+ (let ((gnus-summary-pipe-output-default-command
+ gnus-summary-pipe-output-default-command))
+ (gnus-summary-save-in-pipe command))
+ (setq gnus-summary-muttprint-program command))
;;; Article file names when saving.
(defun article-verify-x-pgp-sig ()
"Verify X-PGP-Sig."
+ ;; <ftp://ftp.isc.org/pub/pgpcontrol/FORMAT>
(interactive)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(let ((sig (with-current-buffer gnus-original-article-buffer
(put-text-property (match-end 0) (point-max)
'face eface)))))))))
+(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs.
+
(defun article-verify-cancel-lock ()
"Verify Cancel-Lock header."
(interactive)
(canlock-verify gnus-original-article-buffer)))
(eval-and-compile
- (mapcar
+ (mapc
(lambda (func)
(let (afunc gfunc)
(if (consp func)
`(lambda (&optional interactive &rest args)
,(documentation afunc t)
(interactive (list t))
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(if interactive
(call-interactively ',afunc)
(apply ',afunc args))))))))
article-date-english
article-date-iso8601
article-date-original
+ article-treat-date
article-date-ut
article-decode-mime-words
article-decode-charset
article-decode-encoded-words
article-date-user
article-date-lapsed
+ article-date-combined-lapsed
article-emphasize
article-treat-dumbquotes
+ article-treat-non-ascii
article-normalize-headers
-;; (article-show-all . gnus-article-show-all-headers)
+ ;;(article-show-all . gnus-article-show-all-headers)
)))
\f
;;;
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
- "e" gnus-summary-edit-article
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"F" gnus-article-followup-with-original
"\C-hk" gnus-article-describe-key
"\C-hc" gnus-article-describe-key-briefly
+ "\C-hb" gnus-article-describe-bindings
+ "e" gnus-article-read-summary-keys
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
"\M-#" gnus-article-read-summary-keys
(substitute-key-definition
'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map)
+ "W" gnus-article-wide-reply-with-original)
+(if (featurep 'xemacs)
+ (set-keymap-default-binding gnus-article-send-map
+ 'gnus-article-read-summary-send-keys)
+ (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys))
+
(defun gnus-article-make-menu-bar ()
(unless (boundp 'gnus-article-commands-menu)
(gnus-summary-make-menu-bar))
- (gnus-turn-off-edit-menu 'article)
(unless (boundp 'gnus-article-article-menu)
(easy-menu-define
gnus-article-article-menu gnus-article-mode-map ""
(gnus-run-hooks 'gnus-article-menu-hook)))
+(defvar bookmark-make-record-function)
+
(defun gnus-article-mode ()
"Major mode for displaying an article.
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(set (make-local-variable 'gnus-page-broken) nil)
- (make-local-variable 'gnus-button-marker-list)
(make-local-variable 'gnus-article-current-summary)
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
+ (set (make-local-variable 'bookmark-make-record-function)
+ 'gnus-summary-bookmark-make-record)
;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
;; face.
(set (make-local-variable 'nobreak-char-display) nil)
(setq cursor-in-non-selected-windows nil)
- (setq truncate-lines gnus-article-truncate-lines)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t
(mm-enable-multibyte)
(gnus-run-mode-hooks 'gnus-article-mode-hook))
-(defvar gnus-button-marker-list nil
- "Regexp matching any of the regexps from `gnus-button-alist'.
-Internal variable.")
-
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(let* ((name (if gnus-single-article-buffer "*Article*"
(gnus-set-global-variables)))
(gnus-article-setup-highlight-words)
;; Init original article buffer.
- (save-excursion
- (set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer)
(mm-enable-multibyte)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
nil)
(error "Action aborted"))
t)))
- (save-excursion
- (set-buffer name)
+ (with-current-buffer name
(set (make-local-variable 'gnus-article-edit-mode) nil)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
(setq gnus-article-mime-handle-alist nil)
(buffer-disable-undo)
(setq buffer-read-only t)
- ;; This list just keeps growing if we don't reset it.
- (setq gnus-button-marker-list nil)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
+ (setq truncate-lines gnus-article-truncate-lines)
(current-buffer))
- (save-excursion
- (set-buffer (gnus-get-buffer-create name))
+ (with-current-buffer (gnus-get-buffer-create name)
(gnus-article-mode)
+ (setq truncate-lines gnus-article-truncate-lines)
(make-local-variable 'gnus-summary-buffer)
(setq gnus-summary-buffer
(gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
+ (cond
+ ((and gnus-article-update-date-headers
+ (not article-lapsed-timer))
+ (gnus-start-date-timer gnus-article-update-date-headers))
+ ((and (not gnus-article-update-date-headers)
+ article-lapsed-timer)
+ (gnus-stop-date-timer)))
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
(when article-window
(set-window-start
article-window
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(goto-char (point-min))
(if (not line)
(point-min)
(if (or (eq result 'pseudo)
(eq result 'nneething))
(progn
- (save-excursion
- (set-buffer summary-buffer)
+ (with-current-buffer summary-buffer
(push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
gnus-current-article 0
(not (eq article gnus-current-article)))
;; Seems like a new article has been selected.
;; `gnus-current-article' must be an article number.
- (save-excursion
- (set-buffer summary-buffer)
+ (with-current-buffer summary-buffer
(push article gnus-newsgroup-history)
(setq gnus-last-article gnus-current-article
gnus-current-article article
(vector (caddr c) (car c) :active t))
gnus-mime-button-commands)))
+(defvar gnus-url-button-commands
+ '((gnus-article-copy-string "u" "Copy URL to kill ring")))
+
+(defvar gnus-url-button-map
+ (let ((map (make-sparse-keymap)))
+ (dolist (c gnus-url-button-commands)
+ (define-key map (cadr c) (car c)))
+ map))
+
+(easy-menu-define
+ gnus-url-button-menu gnus-url-button-map "URL button menu."
+ `("Url Button"
+ ,@(mapcar (lambda (c)
+ (vector (caddr c) (car c) :active t))
+ gnus-url-button-commands)))
+
+(defmacro gnus-bind-safe-url-regexp (&rest body)
+ "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'."
+ `(let ((mm-w3m-safe-url-regexp
+ (let ((group (if (and (eq major-mode 'gnus-article-mode)
+ (gnus-buffer-live-p
+ gnus-article-current-summary))
+ (with-current-buffer gnus-article-current-summary
+ gnus-newsgroup-name)
+ gnus-newsgroup-name)))
+ (if (cond ((not group)
+ ;; Maybe we're in a mml-preview buffer
+ ;; and no group is selected.
+ t)
+ ((stringp gnus-safe-html-newsgroups)
+ (string-match gnus-safe-html-newsgroups group))
+ ((consp gnus-safe-html-newsgroups)
+ (member group gnus-safe-html-newsgroups)))
+ nil
+ mm-w3m-safe-url-regexp))))
+ ,@body))
+
(defun gnus-mime-button-menu (event prefix)
"Construct a context-sensitive menu of MIME commands."
(interactive "e\nP")
(or (search-forward "\n\n") (goto-char (point-max)))
(let ((inhibit-read-only t))
(delete-region (point) (point-max))
- (mm-display-parts handles))))))
+ (gnus-bind-safe-url-regexp (mm-display-parts handles)))))))
(defun gnus-article-jump-to-part (n)
"Jump to MIME part N."
(interactive "P")
- (pop-to-buffer gnus-article-buffer)
- ;; FIXME: why is it necessary?
- (sit-for 0)
- (let ((parts (length gnus-article-mime-handle-alist)))
- (or n (setq n
- (string-to-number
- (read-string ;; Emacs 21 doesn't have `read-number'.
- (format "Jump to part (2..%s): " parts)))))
+ (let ((parts (with-current-buffer gnus-article-buffer
+ (length gnus-article-mime-handle-alist))))
+ (when (zerop parts)
+ (error "No such part"))
+ (pop-to-buffer gnus-article-buffer)
+ (or n
+ (setq n (if (= parts 1)
+ 1
+ (read-number (format "Jump to part (1..%s): " parts)))))
(unless (and (integerp n) (<= n parts) (>= n 1))
(setq n
(progn
(t
(gnus-article-goto-part n)))))
+(defvar gnus-mime-buttonized-part-id nil
+ "ID of a mime part that should be buttonized.
+`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.")
+
(eval-when-compile
(defsubst gnus-article-edit-part (handles &optional current-id)
"Edit an article in order to delete a mime part.
,(gnus-group-read-only-p)
,gnus-summary-buffer no-highlight))
t)
- (gnus-article-edit-done)
- (gnus-summary-expand-window)
- (gnus-summary-show-article)
+ ;; Force buttonizing this part.
+ (let ((gnus-mime-buttonized-part-id current-id))
+ (gnus-article-edit-done))
+ (gnus-configure-windows 'article)
(when (and current-id (integerp gnus-auto-select-part))
(gnus-article-jump-to-part
- (+ current-id gnus-auto-select-part)))))
+ (min (max (+ current-id gnus-auto-select-part) 1)
+ (with-current-buffer gnus-article-buffer
+ (length gnus-article-mime-handle-alist)))))))
(defun gnus-mime-replace-part (file)
"Replace MIME part under point with an external body."
;; Useful if file has already been saved to disk
(interactive
(list
- (mm-with-multibyte
- (read-file-name "Replace MIME part with file: "
- (or mm-default-directory default-directory)
- nil nil))))
+ (read-file-name "Replace MIME part with file: "
+ (or mm-default-directory default-directory)
+ nil nil)))
(gnus-mime-save-part-and-strip file))
(defun gnus-mime-save-part-and-strip (&optional file)
(handles gnus-article-mime-handles)
(none "(none)")
(description
- (mail-decode-encoded-word-string (or (mm-handle-description data)
- none)))
+ (let ((desc (mm-handle-description data)))
+ (when desc
+ (mail-decode-encoded-word-string desc))))
(filename
(or (mail-content-type-get (mm-handle-disposition data) 'filename)
none))
(unless data
(error "No MIME part under point"))
(with-current-buffer (mm-handle-buffer data)
- (let ((bsize (format "%s" (buffer-size))))
+ (let ((bsize (buffer-size)))
(erase-buffer)
(insert
(concat
"|\n"
"| Type: " type "\n"
"| Filename: " filename "\n"
- "| Size (encoded): " bsize " Byte\n"
- "| Description: " description "\n"
+ "| Size (encoded): " (format "%s byte%s\n"
+ bsize (if (= bsize 1)
+ ""
+ "s"))
+ (when description
+ (concat "| Description: " description "\n"))
"`----\n"))
(setcdr data
(cdr (mm-make-handle
- nil `("text/plain") nil nil
+ nil `("text/plain" (charset . gnus-decoded)) nil nil
(list "attachment")
(format "Deleted attachment (%s bytes)" bsize))))))
;; (set-buffer gnus-summary-buffer)
(when data
(mm-save-part data))))
-(defun gnus-mime-pipe-part ()
- "Pipe the MIME part under point to a process."
+(defun gnus-mime-pipe-part (&optional cmd)
+ "Pipe the MIME part under point to a process.
+Use CMD as the process."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
(when data
- (mm-pipe-part data))))
+ (mm-pipe-part data cmd))))
(defun gnus-mime-view-part ()
"Interactively choose a viewing method for the MIME part under point."
;; Content-Disposition: attachment; filename=...
(cdr (assq 'filename (cdr (mm-handle-disposition handle))))))
(def-type (and name (mm-default-file-encoding name))))
- (and def-type (cons def-type 0))))
+ (or (and def-type (cons def-type 0))
+ (and handle
+ (equal (mm-handle-media-supertype handle) "text")
+ '("text/plain" . 0))
+ '("application/octet-stream" . 0))))
(defun gnus-mime-view-part-as-type (&optional mime-type pred)
"Choose a MIME media type, and view the part as such.
(unless mime-type
(setq mime-type
(let ((default (gnus-mime-view-part-as-type-internal)))
- (completing-read
- (format "View as MIME type (default %s): "
- (car default))
- (mapcar #'list (mailcap-mime-types))
- pred nil nil nil
+ (gnus-completing-read
+ "View as MIME type"
+ (if pred
+ (gnus-remove-if-not pred (mailcap-mime-types))
+ (mailcap-mime-types))
+ nil nil nil
(car default)))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
(mm-handle-id handle)))
(setq gnus-article-mime-handles
(mm-merge-handles gnus-article-mime-handles handle))
+ (when (mm-handle-displayed-p handle)
+ (mm-remove-part handle))
(gnus-mm-display-part handle))))
(defun gnus-mime-copy-part (&optional handle arg)
(if (or coding-system
(and charset
(setq coding-system (mm-charset-to-coding-system charset))
- (not (eq charset 'ascii))))
+ (not (eq coding-system 'ascii))))
(progn
(mm-enable-multibyte)
(insert (mm-decode-coding-string contents coding-system))
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))))
(forward-line 2)
- (mm-insert-inline
- handle
- (if (or coding-system
- (and charset
- (setq coding-system
- (mm-charset-to-coding-system charset))
- (not (eq coding-system 'ascii))))
- (mm-decode-coding-string contents coding-system)
- (mm-string-to-multibyte contents)))
+ (mm-display-inline handle)
(goto-char b)))))
-(defun gnus-mime-strip-charset-parameters (handle)
- "Strip charset parameters from HANDLE."
+(defun gnus-mime-set-charset-parameters (handle charset)
+ "Set CHARSET to parameters in HANDLE.
+CHARSET may either be a string or a symbol."
+ (unless (stringp charset)
+ (setq charset (symbol-name charset)))
(if (stringp (car handle))
- (mapc #'gnus-mime-strip-charset-parameters (cdr handle))
+ (dolist (h (cdr handle))
+ (gnus-mime-set-charset-parameters h charset))
(let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
"message/external-body")
(progn
(mm-extern-cache-contents handle))
(mm-handle-cache handle))
handle)))
- (charset (assq 'charset (cdr type))))
- (when charset
- (delq charset type)))))
+ (param (assq 'charset (cdr type))))
+ (if param
+ (setcdr param charset)
+ (setcdr type (cons (cons 'charset charset) (cdr type)))))))
(defun gnus-mime-view-part-as-charset (&optional handle arg)
"Insert the MIME part under point into the current buffer using the
(let ((handle (or handle (get-text-property (point) 'gnus-data)))
(fun (get-text-property (point) 'gnus-callback))
(gnus-newsgroup-ignored-charsets 'gnus-all)
- gnus-newsgroup-charset form preferred parts)
+ charset form preferred parts)
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle))
- (when fun
- (setq gnus-newsgroup-charset
- (or (cdr (assq arg gnus-summary-show-article-charset-alist))
- (mm-read-coding-system "Charset: ")))
- (gnus-mime-strip-charset-parameters handle)
+ (when (prog1
+ (and fun
+ (setq charset
+ (or (cdr (assq
+ arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: "))))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)))
+ (gnus-mime-set-charset-parameters handle charset)
(when (and (consp (setq form (cdr-safe fun)))
(setq form (ignore-errors
(assq 'gnus-mime-display-alternative form)))
(mm-enable-external t))
(if (not (stringp method))
(gnus-mime-view-part-as-type
- nil (lambda (types) (stringp (mailcap-mime-info (car types)))))
+ nil (lambda (type) (stringp (mailcap-mime-info type))))
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle))))))
+ (mm-display-part handle nil t)))))
(defun gnus-mime-view-part-internally (&optional handle)
"View the MIME part under point with an internal viewer.
(inhibit-read-only t))
(if (not (mm-inlinable-p handle))
(gnus-mime-view-part-as-type
- nil (lambda (types) (mm-inlinable-p handle (car types))))
+ nil (lambda (type) (mm-inlinable-p handle type)))
(when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle))))))
+ (gnus-bind-safe-url-regexp (mm-display-part handle))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at \(point\)."
(interactive
- (list (completing-read "Action: " gnus-mime-action-alist nil t)))
+ (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t)))
(gnus-article-check-buffer)
(let ((action-pair (assoc action gnus-mime-action-alist)))
(if action-pair
(when (gnus-article-goto-part n)
;; We point the cursor and the arrow at the MIME button
;; when the `function' prompt the user for something.
+ (unless (and (pos-visible-in-window-p)
+ (> (count-lines (point) (window-end))
+ (/ (1- (window-height)) 3)))
+ (recenter (/ (1- (window-height)) 3)))
(let ((cursor-in-non-selected-windows t)
(overlay-arrow-string "=>")
(overlay-arrow-position (point-marker)))
(funcall function))
(interactive
(call-interactively
- function
- (cdr (assq n gnus-article-mime-handle-alist))))
+ function (get-text-property (point) 'gnus-data)))
(t
(funcall function
- (cdr (assq n gnus-article-mime-handle-alist)))))
+ (get-text-property (point) 'gnus-data))))
(set-marker overlay-arrow-position nil)
(unless gnus-auto-select-part
(gnus-select-frame-set-input-focus frame)
1))
(defun gnus-article-view-part (&optional n)
- "View MIME part N, which is the numerical prefix."
+ "View MIME part N, which is the numerical prefix.
+If the part is already shown, hide the part. If N is nil, view
+all parts."
(interactive "P")
(with-current-buffer gnus-article-buffer
(or (numberp n) (setq n (gnus-article-mime-match-handle-first
(save-restriction
(narrow-to-region (point)
(if (eobp) (point) (1+ (point))))
- (mm-display-part handle)
+ (gnus-bind-safe-url-regexp (mm-display-part handle))
;; We narrow to the part itself and
;; then call the treatment functions.
(goto-char (point-min))
(defun gnus-article-goto-part (n)
"Go to MIME part N."
- (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
+ (when gnus-break-pages
+ (widen))
+ (prog1
+ (let ((start (text-property-any (point-min) (point-max) 'gnus-part n))
+ part handle end next handles)
+ (when start
+ (goto-char start)
+ (if (setq handle (get-text-property start 'gnus-data))
+ start
+ ;; Go to the displayed subpart, assuming this is
+ ;; multipart/alternative.
+ (setq part start
+ end (point-at-eol))
+ (while (and (not handle)
+ part
+ (< part end)
+ (setq next (text-property-not-all part end
+ 'gnus-data nil)))
+ (setq part next
+ handle (get-text-property part 'gnus-data))
+ (push (cons handle part) handles)
+ (unless (mm-handle-displayed-p handle)
+ (setq handle nil
+ part (text-property-any part end 'gnus-data nil))))
+ (unless handle
+ ;; No subpart is displayed, so we find preferred one.
+ (setq part
+ (cdr (assq (mm-preferred-alternative
+ (nreverse (mapcar 'car handles)))
+ handles))))
+ (if part
+ (goto-char (1+ part))
+ start))))
+ (when gnus-break-pages
+ (gnus-narrow-to-page))))
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
(mail-content-type-get (mm-handle-type handle) 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
- (gnus-tmp-description
- (mail-decode-encoded-word-string (or (mm-handle-description handle)
- "")))
+ (gnus-tmp-description (or (mm-handle-description handle) ""))
(gnus-tmp-dots
(if (if displayed (car displayed)
(mm-handle-displayed-p handle))
:action 'gnus-widget-press-button
:button-keymap gnus-mime-button-map
:help-echo
- (lambda (widget/window &optional overlay pos)
+ (lambda (widget)
;; Needed to properly clear the message due to a bug in
;; wid-edit (XEmacs only).
(if (boundp 'help-echo-owns-message)
(format
"%S: %s the MIME part; %S: more options"
(aref gnus-mouse-2 0)
- ;; XEmacs will get a single widget arg; Emacs 21 will get
- ;; window, overlay, position.
- (if (mm-handle-displayed-p
- (if overlay
- (with-current-buffer (gnus-overlay-buffer overlay)
- (widget-get (widget-at (gnus-overlay-start overlay))
- :mime-handle))
- (widget-get widget/window :mime-handle)))
+ (if (mm-handle-displayed-p (widget-get widget :mime-handle))
"hide" "show")
(aref gnus-down-mouse-3 0))))))
(save-restriction
(article-goto-body)
(narrow-to-region (point) (point-max))
- (gnus-treat-article nil 1 1)
+ (gnus-treat-article nil 1 1 "text/plain")
(widen)))
(unless ihandles
;; Highlight the headers.
(while ignored
(when (string-match (pop ignored) type)
(throw 'ignored nil)))
- (if (and (setq not-attachment
+ (if (and (not (and (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-inhibit-images)
+ gnus-inhibit-images)
+ (string-match "\\`image/" type)))
+ (setq not-attachment
(and (not (mm-inline-override-p handle))
(or (not (mm-handle-disposition handle))
(equal (car (mm-handle-disposition handle))
((or (bobp) (eq (char-before (1- (point))) ?\n)) 0)
(t 1))))
(when (or (not display)
- (not (gnus-unbuttonized-mime-type-p type)))
+ (not (gnus-unbuttonized-mime-type-p type))
+ (eq id gnus-mime-buttonized-part-id))
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
(set-buffer gnus-summary-buffer)
(error))
gnus-newsgroup-ignored-charsets)))
- (mm-display-part handle t))
+ (gnus-bind-safe-url-regexp (mm-display-part handle t)))
(goto-char (point-max)))
((and text not-attachment)
(when move
(forward-line -1)
(setq beg (point)))
(gnus-article-insert-newline)
- (mm-insert-inline
- handle
- (let ((charset (mail-content-type-get (mm-handle-type handle)
- 'charset)))
- (cond ((not charset)
- (mm-string-as-multibyte (mm-get-part handle)))
- ((eq charset 'gnus-decoded)
- (with-current-buffer (mm-handle-buffer handle)
- (buffer-string)))
- (t
- (mm-decode-string (mm-get-part handle) charset)))))
+ (mm-display-inline handle)
(goto-char (point-max))))
;; Do highlighting.
(save-excursion
(mail-parse-ignored-charsets
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-ignored-charsets)))
- (mm-display-part preferred)
+ (gnus-bind-safe-url-regexp (mm-display-part preferred))
;; Do highlighting.
(save-excursion
(save-restriction
(gnus-treat-article
nil (length gnus-article-mime-handle-alist)
(gnus-article-mime-total-parts)
- (mm-handle-media-type handle))))))
+ (mm-handle-media-type preferred))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(when ibegend
If given a numerical ARG, move forward ARG pages."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 0))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
+ (with-current-buffer gnus-article-buffer
(widen)
;; Remove any old next/prev buttons.
(when (gnus-visual-p 'page-marker)
(let ((inhibit-read-only t))
(gnus-remove-text-with-property 'gnus-prev)
(gnus-remove-text-with-property 'gnus-next)))
- (if
- (cond ((< arg 0)
- (re-search-backward page-delimiter nil 'move (1+ (abs arg))))
- ((> arg 0)
- (re-search-forward page-delimiter nil 'move arg)))
- (goto-char (match-end 0))
- (save-excursion
- (goto-char (point-min))
- (setq gnus-page-broken
- (and (re-search-forward page-delimiter nil t) t))))
- (when gnus-page-broken
- (narrow-to-region
- (point)
- (if (re-search-forward page-delimiter nil 'move)
- (match-beginning 0)
- (point)))
- (when (and (gnus-visual-p 'page-marker)
- (> (point-min) (save-restriction (widen) (point-min))))
- (save-excursion
- (goto-char (point-min))
- (gnus-insert-prev-page-button)))
- (when (and (gnus-visual-p 'page-marker)
- (< (point-max) (save-restriction (widen) (point-max))))
- (save-excursion
- (goto-char (point-max))
- (gnus-insert-next-page-button))))))
+ (let (st nd pt)
+ (when (save-excursion
+ (cond ((< arg 0)
+ (if (re-search-backward page-delimiter nil 'move (abs arg))
+ (prog1
+ (setq nd (match-beginning 0)
+ pt nd)
+ (when (re-search-backward page-delimiter nil t)
+ (setq st (match-end 0))))
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0)
+ pt (point-min)))))
+ ((> arg 0)
+ (if (re-search-forward page-delimiter nil 'move arg)
+ (prog1
+ (setq st (match-end 0)
+ pt st)
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0))))
+ (when (re-search-backward page-delimiter nil t)
+ (setq st (match-end 0)
+ pt (point-max)))))
+ (t
+ (when (re-search-backward page-delimiter nil t)
+ (goto-char (setq st (match-end 0))))
+ (when (re-search-forward page-delimiter nil t)
+ (setq nd (match-beginning 0)))
+ (or st nd))))
+ (setq gnus-page-broken t)
+ (when pt (goto-char pt))
+ (narrow-to-region (or st (point-min)) (or nd (point-max)))
+ (when (gnus-visual-p 'page-marker)
+ (save-excursion
+ (when nd
+ (goto-char nd)
+ (gnus-insert-next-page-button))
+ (when st
+ (goto-char st)
+ (gnus-insert-prev-page-button))))))))
;; Article mode commands
(defun gnus-article-goto-prev-page ()
"Show the previous page of the article."
(interactive)
- (if (bobp)
+ (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer?
(gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
(gnus-article-prev-page nil)))
If end of article, return non-nil. Otherwise return nil.
Argument LINES specifies lines to be scrolled up."
(interactive "p")
- (move-to-window-line -1)
- (if (save-excursion
- (end-of-line)
- (and (pos-visible-in-window-p) ;Not continuation line.
- (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
+ (move-to-window-line (if (featurep 'xemacs) -1 (- -1 scroll-margin)))
+ (if (and (not (and gnus-article-over-scroll
+ (> (count-lines (window-start) (point-max))
+ (if (featurep 'xemacs)
+ (or lines (1- (window-height)))
+ (+ (or lines (1- (window-height))) scroll-margin)))))
+ (save-excursion
+ (end-of-line)
+ (and (pos-visible-in-window-p) ;Not continuation line.
+ (>= (point) (point-max)))))
;; Nothing in this page.
(if (or (not gnus-page-broken)
(save-excursion
(gnus-article-next-page-1 lines)
nil))
-(defmacro gnus-article-beginning-of-window ()
+(defun gnus-article-beginning-of-window ()
"Move point to the beginning of the window.
In Emacs, the point is placed at the line number which `scroll-margin'
specifies."
(if (featurep 'xemacs)
- '(move-to-window-line 0)
- '(move-to-window-line
- (min (max 0 scroll-margin)
- (max 1 (- (window-height)
- (if mode-line-format 1 0)
- (if header-line-format 1 0)))))))
+ (move-to-window-line 0)
+ ;; There is an obscure bug in Emacs that makes it impossible to
+ ;; scroll past big pictures in the article buffer. Try to fix
+ ;; this by adding a sanity check by counting the lines visible.
+ (when (> (count-lines (window-start) (window-end)) 30)
+ (move-to-window-line
+ (min (max 0 scroll-margin)
+ (max 1 (- (window-height)
+ (if mode-line-format 1 0)
+ (if header-line-format 1 0)
+ 2)))))))
(defun gnus-article-next-page-1 (lines)
- (when (and (not (featurep 'xemacs))
- (numberp lines)
- (> lines 0)
- (numberp (symbol-value 'scroll-margin))
- (> (symbol-value 'scroll-margin) 0))
- ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
- ;; too many number of lines if `scroll-margin' is set as two or greater.
- (setq lines (min lines
- (max 0 (- (count-lines (window-start) (point-max))
- (symbol-value 'scroll-margin))))))
(condition-case ()
(let ((scroll-in-place nil))
(scroll-up lines))
(progn
(gnus-narrow-to-page -1) ;Go to previous page.
(goto-char (point-max))
- (recenter -1))
+ (recenter (if gnus-article-over-scroll
+ (if lines
+ (max (if (featurep 'xemacs)
+ lines
+ (+ lines scroll-margin))
+ 3)
+ (- (window-height) 2))
+ -1)))
(prog1
(condition-case ()
(let ((scroll-in-place nil))
(defun gnus-article-describe-briefly ()
"Describe article mode commands briefly."
(interactive)
- (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")))
-
-(defun gnus-article-summary-command ()
- "Execute the last keystroke in the summary buffer."
- (interactive)
- (let ((obuf (current-buffer))
- (owin (current-window-configuration))
- func)
- (switch-to-buffer gnus-article-current-summary 'norecord)
- (setq func (lookup-key (current-local-map) (this-command-keys)))
- (call-interactively func)
- (set-buffer obuf)
- (set-window-configuration owin)
- (set-window-point (get-buffer-window (current-buffer)) (point))))
-
-(defun gnus-article-summary-command-nosave ()
- "Execute the last keystroke in the summary buffer."
- (interactive)
- (let (func)
- (pop-to-buffer gnus-article-current-summary)
- (setq func (lookup-key (current-local-map) (this-command-keys)))
- (call-interactively func)))
+ (gnus-message 6 "%s" (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")))
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
"Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
"=" "^" "\M-^" "|"))
(nosave-but-article
- '("A\r"))
+ '("A " "A<" "A>" "AM" "AP" "AR" "AT" "A\C-?" "A\M-\r" "A\r" "Ab" "Ae"
+ "An" "Ap" [?A (meta return)] [?A delete]))
(nosave-in-article
- '("\C-d"))
+ '("AS" "\C-d"))
(up-to-top
'("n" "Gn" "p" "Gp"))
keys new-sum-point)
- (save-excursion
- (set-buffer gnus-article-current-summary)
+ (with-current-buffer gnus-article-current-summary
(let (gnus-pick-mode)
- (push (or key last-command-event) unread-command-events)
- (setq keys (if (featurep 'xemacs)
- (events-to-keys (read-key-sequence nil))
- (read-key-sequence nil)))))
+ (setq unread-command-events (nconc unread-command-events
+ (list (or key last-command-event)))
+ keys (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence nil t))
+ (read-key-sequence nil t)))))
(message "")
(cond
((eq (aref keys (1- (length keys))) ?\C-h)
- (with-current-buffer gnus-article-current-summary
- (describe-bindings (substring keys 0 -1))))
+ (gnus-article-describe-bindings (substring keys 0 -1)))
((or (member keys nosaves)
(member keys nosave-but-article)
(member keys nosave-in-article))
(pop-to-buffer gnus-article-current-summary)
;; We disable the pick minor mode commands.
(let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
+ (setq func (key-binding keys t))))
(if (or (not func)
(numberp func))
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
(call-interactively func)
(setq new-sum-point (point)))
(when (member keys nosave-but-article)
(gnus-configure-windows 'article)
(unless (setq win (get-buffer-window summary-buffer 'visible))
(let ((gnus-buffer-configuration
- '(article ((vertical 1.0
- (summary 0.25 point)
- (article 1.0))))))
+ '((article ((vertical 1.0
+ (summary 0.25 point)
+ (article 1.0)))))))
(gnus-configure-windows 'article))
(setq win (get-buffer-window summary-buffer 'visible)))
(gnus-select-frame-set-input-focus (window-frame win))
(select-window win))))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
- (if (and (setq func (let (gnus-pick-mode)
- (lookup-key (current-local-map) keys)))
+ (setq func (let (gnus-pick-mode)
+ (key-binding keys t)))
+ (when (get func 'disabled)
+ (error "Function %s disabled" func))
+ (if (and func
(functionp func)
(condition-case code
(progn
(point))))
(when (and (not not-restore-window)
new-sum-point
+ (window-live-p win)
(with-current-buffer (window-buffer win)
(eq major-mode 'gnus-summary-mode)))
(set-window-point win new-sum-point)
(signal (car err) (cdr err))
(ding))))))))
+(defun gnus-article-read-summary-send-keys ()
+ (interactive)
+ (let ((unread-command-events (list (gnus-character-to-event ?S))))
+ (gnus-article-read-summary-keys)))
+
(defun gnus-article-describe-key (key)
- "Display documentation of the function invoked by KEY. KEY is a string."
- (interactive "kDescribe key: ")
+ "Display documentation of the function invoked by KEY.
+KEY is a string or a vector."
+ (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
+ (read-key-sequence "Describe key: "))))
(gnus-article-check-buffer)
- (if (eq (key-binding key) 'gnus-article-read-summary-keys)
- (save-excursion
- (set-buffer gnus-article-current-summary)
- (let (gnus-pick-mode)
- (if (featurep 'xemacs)
- (progn
- (push (elt key 0) unread-command-events)
- (setq key (events-to-keys
- (read-key-sequence "Describe key: "))))
- (setq unread-command-events
- (mapcar
- (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
- (string-to-list key)))
- (setq key (read-key-sequence "Describe key: "))))
- (describe-key key))
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-keys))
+ (with-current-buffer gnus-article-current-summary
+ (setq unread-command-events
+ (if (featurep 'xemacs)
+ (append key nil)
+ (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
+ (list 'meta (- x 128))
+ x))
+ key)))
+ (let ((cursor-in-echo-area t)
+ gnus-pick-mode)
+ (describe-key (read-key-sequence nil t))))
(describe-key key)))
(defun gnus-article-describe-key-briefly (key &optional insert)
- "Display documentation of the function invoked by KEY. KEY is a string."
- (interactive "kDescribe key: \nP")
+ "Display documentation of the function invoked by KEY.
+KEY is a string or a vector."
+ (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs.
+ (read-key-sequence "Describe key: "))
+ current-prefix-arg))
(gnus-article-check-buffer)
- (if (eq (key-binding key) 'gnus-article-read-summary-keys)
- (save-excursion
- (set-buffer gnus-article-current-summary)
- (let (gnus-pick-mode)
- (if (featurep 'xemacs)
- (progn
- (push (elt key 0) unread-command-events)
- (setq key (events-to-keys
- (read-key-sequence "Describe key: "))))
- (setq unread-command-events
- (mapcar
- (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x))
- (string-to-list key)))
- (setq key (read-key-sequence "Describe key: "))))
- (describe-key-briefly key insert))
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-keys))
+ (with-current-buffer gnus-article-current-summary
+ (setq unread-command-events
+ (if (featurep 'xemacs)
+ (append key nil)
+ (mapcar (lambda (x) (if (and (integerp x) (>= x 128))
+ (list 'meta (- x 128))
+ x))
+ key)))
+ (let ((cursor-in-echo-area t)
+ gnus-pick-mode)
+ (describe-key-briefly (read-key-sequence nil t) insert)))
(describe-key-briefly key insert)))
+;;`gnus-agent-mode' in gnus-agent.el will define it.
+(defvar gnus-agent-summary-mode)
+(defvar gnus-draft-mode)
+;; Calling help-buffer will autoload help-mode.
+(defvar help-xref-stack-item)
+;; Emacs 22 doesn't load it in the batch mode.
+(eval-when-compile
+ (autoload 'help-buffer "help-mode"))
+
+(defun gnus-article-describe-bindings (&optional prefix)
+ "Show a list of all defined keys, and their definitions.
+The optional argument PREFIX, if non-nil, should be a key sequence;
+then we display only bindings that start with that prefix."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((keymap (copy-keymap gnus-article-mode-map))
+ (map (copy-keymap gnus-article-send-map))
+ (sumkeys (where-is-internal 'gnus-article-read-summary-keys))
+ parent agent draft)
+ (define-key keymap "S" map)
+ (define-key map [t] nil)
+ (with-current-buffer gnus-article-current-summary
+ (set-keymap-parent
+ keymap
+ (if (setq parent (keymap-parent gnus-article-mode-map))
+ (prog1
+ (setq parent (copy-keymap parent))
+ (set-keymap-parent parent (current-local-map)))
+ (current-local-map)))
+ (set-keymap-parent map (key-binding "S"))
+ (let (key def gnus-pick-mode)
+ (while sumkeys
+ (setq key (pop sumkeys))
+ (cond ((and (vectorp key) (= (length key) 1)
+ (consp (setq def (aref key 0)))
+ (numberp (car def)) (numberp (cdr def)))
+ (when (< (max (car def) (cdr def)) 128)
+ (setq sumkeys
+ (append (mapcar
+ #'vector
+ (nreverse (gnus-uncompress-range def)))
+ sumkeys))))
+ ((setq def (key-binding key))
+ (unless (eq def 'undefined)
+ (define-key keymap key def))))))
+ (when (boundp 'gnus-agent-summary-mode)
+ (setq agent gnus-agent-summary-mode))
+ (when (boundp 'gnus-draft-mode)
+ (setq draft gnus-draft-mode)))
+ (with-temp-buffer
+ (use-local-map keymap)
+ (set (make-local-variable 'gnus-agent-summary-mode) agent)
+ (set (make-local-variable 'gnus-draft-mode) draft)
+ (describe-bindings prefix))
+ (let ((item `((lambda (prefix)
+ (with-current-buffer ,(current-buffer)
+ (gnus-article-describe-bindings prefix)))
+ ,prefix)))
+ (with-current-buffer (let (help-xref-following) (help-buffer))
+ (setq help-xref-stack-item item)))))
+
(defun gnus-article-reply-with-original (&optional wide)
"Start composing a reply mail to the current message.
The text in the region will be yanked. If the region isn't active,
the entire article will be yanked."
- (interactive "P")
+ (interactive)
(let ((article (cdr gnus-article-current))
contents)
(if (not (gnus-region-active-p))
(gnus-summary-reply
(list (list article contents)) wide)))))
+(defun gnus-article-wide-reply-with-original ()
+ "Start composing a wide reply mail to the current message.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive)
+ (gnus-article-reply-with-original t))
+
(defun gnus-article-followup-with-original ()
"Compose a followup to the current article.
The text in the region will be yanked. If the region isn't active,
gnus-summary-buffer
(get-buffer gnus-summary-buffer)
(gnus-buffer-exists-p gnus-summary-buffer))
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let ((header (gnus-summary-article-header article)))
(when (< article 0)
(cond
(with-current-buffer gnus-original-article-buffer
(and (equal (car gnus-original-article) group)
(eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
+ ;; `insert-buffer-substring' would incorrectly use the
+ ;; equivalent of string-make-multibyte which amount to decoding
+ ;; with locale-coding-system, causing failure of
+ ;; subsequent decoding.
+ (insert (mm-string-to-multibyte
+ (with-current-buffer gnus-original-article-buffer
+ (buffer-substring (point-min) (point-max)))))
'article)
;; Check the backlog.
((and gnus-keep-backlog
(point))
(set-buffer buf))))))
+(defun gnus-block-private-groups (group)
+ (if (gnus-news-group-p group)
+ ;; Block nothing in news groups.
+ nil
+ ;; Block everything anywhere else.
+ "."))
+
+(defun gnus-blocked-images ()
+ (if (functionp gnus-blocked-images)
+ (funcall gnus-blocked-images gnus-newsgroup-name)
+ gnus-blocked-images))
+
;;;
;;; Article editing
;;;
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
;; Flush original article as well.
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq gnus-original-article nil)))
+ (gnus-flush-original-article-buffer)
(when gnus-use-cache
(gnus-cache-update-article
(car gnus-article-current) (cdr gnus-article-current)))
(set-window-point (get-buffer-window buf) (point)))
(gnus-summary-show-article))
+(defun gnus-flush-original-article-buffer ()
+ (when (get-buffer gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq gnus-original-article nil))))
+
(defun gnus-article-edit-exit ()
"Exit the article editing without updating."
(interactive)
(concat
"\\(?:"
;; Match paired parentheses, e.g. in Wikipedia URLs:
- "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]"
+ ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com
+ "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]*"
"\\|"
"[" chars punct "]+" "[" chars "]"
"\\)"))
(function :tag "Other"))
:group 'gnus-article-buttons)
-(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
- "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
-If the default site is too slow, try to find a CTAN mirror, see
-<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
-the variable `gnus-button-handle-ctan'."
- :version "22.1"
- :group 'gnus-article-buttons
- :link '(custom-manual "(gnus)Group Parameters")
- :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
- (const "http://tug.ctan.org/tex-archive/")
- (const "http://www.dante.de/CTAN/")
- (string :tag "Other")))
-
-(defcustom gnus-button-ctan-handler 'browse-url
- "Function to use for displaying CTAN links.
-The function must take one argument, the string naming the URL."
- :version "22.1"
- :type '(choice (function-item :tag "Browse Url" browse-url)
- (function :tag "Other"))
- :group 'gnus-article-buttons)
-
-(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
- "Bogus strings removed from CTAN URLs."
- :version "22.1"
- :group 'gnus-article-buttons
- :type '(choice (const "^/?tex-archive/\\|/")
- (regexp :tag "Other")))
-
-(defcustom gnus-button-ctan-directory-regexp
- (regexp-opt
- (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
- "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
- "languages" "macros" "nonfree" "obsolete" "support" "systems"
- "tds" "tools" "usergrps" "web") t)
- "Regular expression for ctan directories.
-It should match all directories in the top level of `gnus-ctan-url'."
- :version "22.1"
- :group 'gnus-article-buttons
- :type 'regexp)
-
(defcustom gnus-button-mid-or-mail-regexp
(concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
gnus-button-valid-fqdn-regexp
(-20.0 . "\\.fsf@") ;; Gnus
(-20.0 . "^slrn")
(-20.0 . "^Pine")
+ (-20.0 . "^alpine\\.")
(-20.0 . "_-_") ;; Subject change in thread
;;
(-20.0 . "\\.ln@") ;; leafnode
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
-;; FIXME: Maybe we should merge some of the functions that do quite similar
-;; stuff?
-
(defun gnus-button-handle-describe-function (url)
"Call `describe-function' when pushing the corresponding URL button."
(describe-function
(gnus-message 1 "Cannot locale library `%s'." url)
(find-file-read-only file))))
-(defun gnus-button-handle-ctan (url)
- "Call `browse-url' when pushing a CTAN URL button."
- (funcall
- gnus-button-ctan-handler
- (concat
- gnus-ctan-url
- (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
-
-(defcustom gnus-button-tex-level 5
- "*Integer that says how many TeX-related buttons Gnus will show.
-The higher the number, the more buttons will appear and the more false
-positives are possible. Note that you can set this variable local to
-specific groups. Setting it higher in TeX groups is probably a good idea.
-See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
-how to set variables in specific groups."
- :version "22.1"
- :group 'gnus-article-buttons
- :link '(custom-manual "(gnus)Group Parameters")
- :type 'integer)
-
(defcustom gnus-button-man-level 5
"*Integer that says how many man-related buttons Gnus will show.
The higher the number, the more buttons will appear and the more false
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)"
0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
- ;; CTAN
- ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
- gnus-button-ctan-directory-regexp
- "[^][>)!;:,'\n\t ]+\\)")
- 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
- ((concat "\\btex-archive/\\("
- gnus-button-ctan-directory-regexp
- "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
- 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
- ((concat
- "\\b\\("
- gnus-button-ctan-directory-regexp
- "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
- 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
- ;; This is info (home-grown style) <info://foo/bar+baz>
+ ;; Info Konqueror style <info:/foo/bar baz>.
+ ;; Must come before " Gnus home-grown style".
+ ("\\binfo://?\\([^'\">\n\t]+\\)"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
+ ;; Info, Gnus home-grown style (deprecated) <info://foo/bar+baz>
("\\binfo://\\([^'\">\n\t ]+\\)"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
;; Info GNOME style <info:foo#bar_baz>
1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
(>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
- ;; Info links like `C-h i d m CC Mode RET'
- 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n,]*\\)\\)?"
+ ;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET'
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0)
;; This is custom
- ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
+ ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET\\>" 0
(>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2)
;; Emacs help commands
- ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
;; regexp doesn't match arguments containing ` '.
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
- ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
- ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
- ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
;; The following entries may lead to many false positives so don't enable
;; them by default (use a high button level).
0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
- ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
- ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
;; Unlike the other regexps we really have to require quoting
;; here to determine where it ends.
1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
- ("<URL: *\\([^<>]*\\)>"
- 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
- ;; RFC 2396 (2.4.3., delims) ...
- ("\"URL: *\\([^\"]*\\)\""
+ ("<URL: *\\([^\n<>]*\\)>"
1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
;; RFC 2396 (2.4.3., delims) ...
- ("\"URL: *\\([^\"]*\\)\""
+ ("\"URL: *\\([^\n\"]*\\)\""
1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
;; Raw URLs.
(gnus-button-url-regexp
(repeat :tag "Par"
:inline t
(integer :tag "Regexp group")))))
+(put 'gnus-button-alist 'risky-local-variable t)
(defcustom gnus-header-button-alist
'(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
(repeat :tag "Par"
:inline t
(integer :tag "Regexp group")))))
+(put 'gnus-header-button-alist 'risky-local-variable t)
;;; Commands:
(gnus-article-highlight-headers)
(gnus-article-highlight-citation force)
(gnus-article-highlight-signature)
- (gnus-article-add-buttons force)
+ (gnus-article-add-buttons)
(gnus-article-add-buttons-to-head))
(defun gnus-article-highlight-some (&optional force)
(save-restriction
(when (and gnus-signature-face
(gnus-article-narrow-to-signature))
- (gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
+ (gnus-overlay-put (gnus-make-overlay (point-min) (point-max) nil t)
'face gnus-signature-face)
(widen)
(gnus-article-search-signature)
"Say whether PROP exists in the region."
(text-property-not-all b e prop nil))
-(defun gnus-article-add-buttons (&optional force)
+(defun gnus-article-add-buttons ()
"Find external references in the article and make buttons of them.
\"External references\" are things like Message-IDs and URLs, as
specified by `gnus-button-alist'."
- (interactive (list 'force))
+ (interactive)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
(case-fold-search t)
(alist gnus-button-alist)
beg entry regexp)
- ;; Remove all old markers.
- (let (marker entry new-list)
- (while (setq marker (pop gnus-button-marker-list))
- (if (or (< marker (point-min)) (>= marker (point-max)))
- (push marker new-list)
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
- (setq gnus-button-marker-list new-list))
;; We skip the headers.
(article-goto-body)
(setq beg (point))
(setq regexp (eval (car entry)))
(goto-char beg)
(while (re-search-forward regexp nil t)
- (let* ((start (and entry (match-beginning (nth 1 entry))))
- (end (and entry (match-end (nth 1 entry))))
- (from (match-beginning 0)))
- (when (and (or (eq t (nth 2 entry))
- (eval (nth 2 entry)))
+ (let ((start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (from (match-beginning 0)))
+ (when (and (eval (nth 2 entry))
(not (gnus-button-in-region-p
start end 'gnus-callback)))
;; That optional form returned non-nil, so we add the
;; button.
- (gnus-article-add-button
- start end 'gnus-button-push
- (car (push (set-marker (make-marker) from)
- gnus-button-marker-list))))))))))
+ (setq from (set-marker (make-marker) from))
+ (unless (and (eq (car entry) 'gnus-button-url-regexp)
+ (gnus-article-extend-url-button from start end))
+ (gnus-article-add-button start end
+ 'gnus-button-push (list from entry))
+ (gnus-put-text-property
+ start end
+ 'gnus-string (buffer-substring-no-properties
+ start end))))))))))
+
+(defun gnus-article-extend-url-button (beg start end)
+ "Extend url button if url is folded into two or more lines.
+Return non-nil if button is extended. BEG is a marker that points to
+the beginning position of a text containing url. START and END are
+the endpoints of a url button before it is extended. The concatenated
+url is put as the `gnus-button-url' overlay property on the button."
+ (let ((opoint (point))
+ (points (list start end))
+ url delim regexp)
+ (prog1
+ (when (and (progn
+ (goto-char end)
+ (not (looking-at "[\t ]*[\">]")))
+ (progn
+ (goto-char start)
+ (string-match
+ "\\(?:\"\\|\\(<\\)\\)[\t ]*\\(?:url[\t ]*:[\t ]*\\)?\\'"
+ (buffer-substring (point-at-bol) start)))
+ (progn
+ (setq url (list (buffer-substring start end))
+ delim (if (match-beginning 1) ">" "\""))
+ (beginning-of-line)
+ (setq regexp (concat
+ (when (and (looking-at
+ message-cite-prefix-regexp)
+ (< (match-end 0) start))
+ (regexp-quote (match-string 0)))
+ "\
+\[\t ]*\\(?:\\([^\t\n \">]+\\)[\t ]*$\\|\\([^\t\n \">]*\\)[\t ]*"
+ delim "\\)"))
+ (while (progn
+ (forward-line 1)
+ (and (looking-at regexp)
+ (prog1
+ (match-beginning 1)
+ (push (or (match-string 2)
+ (match-string 1))
+ url)
+ (push (setq end (or (match-end 2)
+ (match-end 1)))
+ points)
+ (push (or (match-beginning 2)
+ (match-beginning 1))
+ points)))))
+ (match-beginning 2)))
+ (let (gnus-article-mouse-face widget-mouse-face)
+ (while points
+ (gnus-article-add-button (pop points) (pop points)
+ 'gnus-button-push beg)))
+ (let ((overlay (gnus-make-overlay start end)))
+ (gnus-overlay-put overlay 'evaporate t)
+ (gnus-overlay-put overlay 'gnus-button-url
+ (list (mapconcat 'identity (nreverse url) "")))
+ (when gnus-article-mouse-face
+ (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face)))
+ t)
+ (goto-char opoint))))
;; Add buttons to the head of an article.
(defun gnus-article-add-buttons-to-head ()
;;; External functions:
-(defun gnus-article-add-button (from to fun &optional data)
+(defun gnus-article-add-button (from to fun &optional data text)
"Create a button between FROM and TO with callback FUN and data DATA."
(when gnus-article-button-face
- (gnus-overlay-put (gnus-make-overlay from to)
+ (gnus-overlay-put (gnus-make-overlay from to nil t)
'face gnus-article-button-face))
(gnus-add-text-properties
from to
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
(widget-convert-button 'link from to :action 'gnus-widget-press-button
+ :help-echo (or text "Follow the link")
+ :keymap gnus-url-button-map
:button-keymap gnus-widget-button-keymap))
+(defun gnus-article-copy-string ()
+ "Copy the string in the button to the kill ring."
+ (interactive)
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-string)))
+ (when data
+ (with-temp-buffer
+ (insert data)
+ (copy-region-as-kill (point-min) (point-max))
+ (message "Copied %s" data)))))
+
;;; Internal functions:
(defun gnus-article-set-globals ()
(let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))))
-(defun gnus-button-entry ()
- ;; Return the first entry in `gnus-button-alist' matching this place.
- (let ((alist gnus-button-alist)
- (entry nil))
- (while alist
- (setq entry (pop alist))
- (if (looking-at (eval (car entry)))
- (setq alist nil)
- (setq entry nil)))
- entry))
-
-(defun gnus-button-push (marker)
+(defun gnus-button-push (marker-and-entry)
;; Push button starting at MARKER.
(save-excursion
- (goto-char marker)
- (let* ((entry (gnus-button-entry))
- (inhibit-point-motion-hooks t)
- (fun (nth 3 entry))
- (args (mapcar (lambda (group)
- (let ((string (match-string group)))
- (set-text-properties
- 0 (length string) nil string)
- string))
- (nthcdr 4 entry))))
- (cond
- ((fboundp fun)
- (apply fun args))
- ((and (boundp fun)
- (fboundp (symbol-value fun)))
- (apply (symbol-value fun) args))
- (t
- (gnus-message 1 "You must define `%S' to use this button"
- (cons fun args)))))))
+ (let* ((marker (car marker-and-entry))
+ (entry (cadr marker-and-entry))
+ (regexp (car entry))
+ (inhibit-point-motion-hooks t))
+ (goto-char marker)
+ ;; This is obviously true, or something bad is happening :)
+ ;; But we need it to have the match-data
+ (when (looking-at (or (if (symbolp regexp)
+ (symbol-value regexp)
+ regexp)))
+ (let ((fun (nth 3 entry))
+ (args (or (and (eq (car entry) 'gnus-button-url-regexp)
+ (get-char-property marker 'gnus-button-url))
+ (mapcar (lambda (group)
+ (let ((string (match-string group)))
+ (set-text-properties
+ 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry)))))
+
+ (cond
+ ((fboundp fun)
+ (apply fun args))
+ ((and (boundp fun)
+ (fboundp (symbol-value fun)))
+ (apply (symbol-value fun) args))
+ (t
+ (gnus-message 1 "You must define `%S' to use this button"
+ (cons fun args)))))))))
(defun gnus-parse-news-url (url)
(let (scheme server port group message-id articles)
(gnus-parse-news-url url)
(cond
(message-id
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(if server
(let ((gnus-refer-article-method
(nconc (list (list 'nntp server))
(unless file
(error "Couldn't find library %s" library))
(find-file file)
- (goto-line (string-to-number line))))
+ (goto-char (point-min))
+ (forward-line (1- (string-to-number line)))))
(defun gnus-button-handle-man (url)
"Fetch a man page."
"Fetch KDE style info URL."
(gnus-info-find-node (gnus-url-unhex-string url)))
+;; (info) will autoload info.el
+(declare-function Info-menu "info" (menu-item &optional fork))
+(declare-function Info-index-next "info" (num))
+
(defun gnus-button-handle-info-keystrokes (url)
"Call `info' when pushing the corresponding URL button."
- ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
- (info)
- (Info-directory)
- (Info-menu url))
+ ;; For links like `C-h i d m gnus RET part RET , ,', `C-h i d m CC Mode RET'.
+ (let (node indx comma)
+ (if (string-match
+ (concat "\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+"
+ "\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
+ "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\>"
+ "\\(?:[ \t\n,]*\\)\\)?")
+ url)
+ (setq node (match-string 2 url)
+ indx (match-string 3 url))
+ (error "Can't parse %s" url))
+ (info)
+ (Info-directory)
+ (Info-menu node)
+ (when (> (length indx) 0)
+ (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET\\>"
+ "\\([ \t\n,]*\\)")
+ indx)
+ (setq comma (match-string 2 indx))
+ (setq indx (match-string 1 indx))
+ (Info-index indx)
+ (when comma
+ (dotimes (i (with-temp-buffer
+ (insert comma)
+ ;; Note: the XEmacs version of `how-many' takes
+ ;; no optional argument.
+ (goto-char (point-min))
+ (how-many ",")))
+ (Info-index-next 1)))
+ nil)))
+
+(autoload 'pgg-snarf-keys-region "pgg")
+;; Called after pgg-snarf-keys-region, which autoloads pgg.el.
+(declare-function pgg-display-output-buffer "pgg" (start end status))
(defun gnus-button-openpgp (url)
"Retrieve and add an OpenPGP key given URL from an OpenPGP header."
(defun gnus-url-mailto (url)
;; Send mail to someone
+ (setq url (replace-regexp-in-string "\n" " " url))
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
(if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
(concat "to=" (match-string 1 url) "&"
(match-string 2 url))
- (concat "to=" url)))
- t)
+ (concat "to=" url))))
subject (cdr-safe (assoc "subject" args)))
(gnus-msg-mail)
(while args
(defvar gnus-next-page-map
(let ((map (make-sparse-keymap)))
- (unless (>= emacs-major-version 21)
- ;; XEmacs doesn't care.
- (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-button-next-page)
(define-key map "\r" 'gnus-button-next-page)
map))
(1- (point))
(point)))
(when gnus-article-button-face
- (gnus-overlay-put (gnus-make-overlay b e)
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
'face gnus-article-button-face))
(widget-convert-button
'link b e
(1- (point))
(point)))
(when gnus-article-button-face
- (gnus-overlay-put (gnus-make-overlay b e)
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
'face gnus-article-button-face))
(widget-convert-button
'link b e
(eq gnus-newsgroup-name
(car gnus-decode-header-methods-cache)))
(setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
- (mapcar (lambda (x)
- (if (symbolp x)
- (nconc gnus-decode-header-methods-cache (list x))
- (if (and gnus-newsgroup-name
- (string-match (car x) gnus-newsgroup-name))
- (nconc gnus-decode-header-methods-cache
- (list (cdr x))))))
- gnus-decode-header-methods))
+ (dolist (x gnus-decode-header-methods)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x)))))))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(save-restriction
;;; Treatment top-level handling.
;;;
-(defun gnus-treat-article (condition &optional part-number total-parts type)
- (let ((length (- (point-max) (point-min)))
+(defvar gnus-inhibit-article-treatments nil)
+
+(defun gnus-treat-article (gnus-treat-condition
+ &optional part-number total-parts gnus-treat-type)
+ (let ((gnus-treat-length (- (point-max) (point-min)))
(alist gnus-treatment-function-alist)
(article-goto-body-goes-to-point-min-p t)
(treated-type
- (or (not type)
+ (or (not gnus-treat-type)
(catch 'found
(let ((list gnus-article-treat-types))
(while list
- (when (string-match (pop list) type)
+ (when (string-match (pop list) gnus-treat-type)
(throw 'found t)))))))
(highlightp (gnus-visual-p 'article-highlight 'highlight))
val elem)
(symbol-value (car elem))))
(when (and (or (consp val)
treated-type)
+ (or (not gnus-inhibit-article-treatments)
+ (eq gnus-treat-condition 'head))
(gnus-treat-predicate val)
(or (not (get (car elem) 'highlight))
highlightp))
(funcall (cadr elem)))))))
;; Dynamic variables.
-(eval-when-compile
- (defvar part-number)
- (defvar total-parts)
- (defvar type)
- (defvar condition)
- (defvar length))
+(defvar part-number)
+(defvar total-parts)
+(defvar gnus-treat-type)
+(defvar gnus-treat-condition)
+(defvar gnus-treat-length)
(defun gnus-treat-predicate (val)
(cond
((null val)
nil)
- (condition
- (eq condition val))
+ (gnus-treat-condition
+ (eq gnus-treat-condition val))
((and (listp val)
(stringp (car val)))
(apply 'gnus-or (mapcar `(lambda (s)
((eq pred 'not)
(not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (car val) type))
+ (equal (car val) gnus-treat-type))
(t
(error "%S is not a valid predicate" pred)))))
((eq val t)
((eq val 'last)
(eq part-number total-parts))
((numberp val)
- (< length val))
+ (< gnus-treat-length val))
(t
(error "%S is not a valid value" val))))
(interactive
(list
(or gnus-article-encrypt-protocol
- (completing-read "Encrypt protocol: "
- gnus-article-encrypt-protocol-alist
- nil t))
+ (gnus-completing-read "Encrypt protocol"
+ (mapcar 'car gnus-article-encrypt-protocol-alist)
+ t))
current-prefix-arg))
+ ;; User might hit `K E' instead of `K e', so prompt once.
+ (when (and gnus-article-encrypt-protocol
+ gnus-novice-user)
+ (unless (gnus-y-or-n-p "Really encrypt article(s)? ")
+ (error "Encrypt aborted")))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(unless func
(error "Can't find the encrypt protocol %s" protocol))
(error "Can't encrypt the article in group %s"
gnus-newsgroup-name))
(gnus-summary-iterate n
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(let ((mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
(summary-buffer gnus-summary-buffer)
(when gnus-keep-backlog
(gnus-backlog-remove-article
(car gnus-article-current) (cdr gnus-article-current)))
- (save-excursion
- (when (get-buffer gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq gnus-original-article nil)))
+ (gnus-flush-original-article-buffer)
(when gnus-use-cache
(gnus-cache-update-article
(car gnus-article-current) (cdr gnus-article-current))))))))
:action 'gnus-widget-press-button
:button-keymap gnus-mime-security-button-map
:help-echo
- (lambda (widget/window &optional overlay pos)
+ (lambda (widget)
;; Needed to properly clear the message due to a bug in
;; wid-edit (XEmacs only).
(when (boundp 'help-echo-owns-message)
(run-hooks 'gnus-art-load-hook)
-;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
;;; gnus-art.el ends here