;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(defvar tool-bar-map))
(require 'gnus)
-(require 'gnus-sum)
+;; Avoid the "Recursive load suspected" error in Emacs 21.1.
+(eval-and-compile
+ (let ((recursive-load-depth-limit 100))
+ (require 'gnus-sum)))
(require 'gnus-spec)
(require 'gnus-int)
(require 'gnus-win)
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
(autoload 'gnus-button-reply "gnus-msg" nil t)
+(autoload 'parse-time-string "parse-time" nil nil)
(autoload 'ansi-color-apply-on-region "ansi-color")
(defgroup gnus-article nil
signatures, but will never scroll down to show you a page consisting
only of boring text. Boring text is controlled by
`gnus-article-boring-faces'."
- :version "21.4"
+ :version "22.1"
:type 'boolean
:group 'gnus-article-hiding)
(symbol :tag "Item in `gnus-article-banner-alist'" none)
regexp
(const :tag "None" nil))))
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-washing)
(defmacro gnus-emphasis-custom-with-format (&rest body)
(or (nth 4 spec) 3)
(intern (format "gnus-emphasis-%s" (nth 2 spec)))))
types))
- '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ '(;; I've never seen anyone use this strikethru convention whereas I've
+ ;; several times seen it triggered by normal text. --Stef
+ ;; Miles suggests that this form is sometimes used but for italics,
+ ;; so maybe we should map it to `italic'.
+ ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
+ ;; 2 3 gnus-emphasis-strikethru)
+ ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
2 3 gnus-emphasis-underline))))
"*Alist that says how to fontify certain phrases.
Each item looks like this:
:link '(custom-manual "(gnus)Article Date")
:group 'gnus-article-washing)
-(eval-and-compile
- (autoload 'mail-extract-address-components "mail-extr"))
-
(defcustom gnus-save-all-headers t
"*If non-nil, don't remove any headers before saving."
:group 'gnus-article-saving
(defcustom gnus-copy-article-ignored-headers nil
"List of headers to be removed when copying an article.
Each element is a regular expression."
- :version "22.0" ;; No Gnus
+ :version "23.0" ;; No Gnus
:type '(repeat regexp)
:group 'gnus-article-various)
:type 'face
:group 'gnus-article-buttons)
-(defcustom gnus-signature-face 'gnus-signature-face
+(defcustom gnus-signature-face 'gnus-signature
"Face used for highlighting a signature in the article buffer.
-Obsolete; use the face `gnus-signature-face' for customizations instead."
+Obsolete; use the face `gnus-signature' for customizations instead."
:type 'face
:group 'gnus-article-highlight
:group 'gnus-article-signature)
-(defface gnus-signature-face
+(defface gnus-signature
'((t
(:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
+;; backward-compatibility alias
+(put 'gnus-signature-face 'face-alias 'gnus-signature)
-(defface gnus-header-from-face
+(defface gnus-header-from
'((((class color)
(background dark))
(:foreground "spring green"))
"Face used for displaying from headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
-(defface gnus-header-subject-face
+(defface gnus-header-subject
'((((class color)
(background dark))
(:foreground "SeaGreen3"))
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
-(defface gnus-header-newsgroups-face
+(defface gnus-header-newsgroups
'((((class color)
(background dark))
(:foreground "yellow" :italic t))
articles."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
-(defface gnus-header-name-face
+(defface gnus-header-name
'((((class color)
(background dark))
(:foreground "SeaGreen"))
"Face used for displaying header names."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
-(defface gnus-header-content-face
+(defface gnus-header-content
'((((class color)
(background dark))
(:foreground "forest green" :italic t))
(:italic t))) "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
(defcustom gnus-header-face-alist
- '(("From" nil gnus-header-from-face)
- ("Subject" nil gnus-header-subject-face)
- ("Newsgroups:.*," nil gnus-header-newsgroups-face)
- ("" gnus-header-name-face gnus-header-content-face))
+ '(("From" nil gnus-header-from)
+ ("Subject" nil gnus-header-subject)
+ ("Newsgroups:.*," nil gnus-header-newsgroups)
+ ("" gnus-header-name gnus-header-content))
"*Controls highlighting of article headers.
An alist of the form (HEADER NAME CONTENT).
To see e.g. security buttons you could set this to
`(\"multipart/signed\")'.
This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-mime
:type '(repeat regexp))
When nil (the default value), then some MIME parts do not get buttons,
as described by the variables `gnus-buttonized-mime-types' and
`gnus-unbuttonized-mime-types'."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-mime
:type 'boolean)
"String used to delimit header and body.
This variable is used by `gnus-article-treat-body-boundary' which can
be controlled by `gnus-treat-body-boundary'."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-various
:type '(choice (item :tag "None" :value nil)
string))
"Defines the location of the faces database.
For information on obtaining this database of pretty pictures, please
see http://www.cs.indiana.edu/picons/ftp/index.html"
- :version "21.4"
+ :version "22.1"
:type '(repeat directory)
:link '(url-link :tag "download"
"http://www.cs.indiana.edu/picons/ftp/index.html")
"Remove carriage returns.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Remove newlines from within URLs.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Remove leading whitespace in headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Display the Date in a format that can be read aloud in English.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
"Unfold folded header lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Fold headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Fold the Newsgroups and Followup-To headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)X-Face' for details."
:group 'gnus-article-treat
- :version "21.4"
+ :version "22.1"
:link '(custom-manual "(gnus)Customizing Articles")
:link '(custom-manual "(gnus)X-Face")
:type gnus-article-treat-head-custom)
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)Picons' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)Picons' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)Picons' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
"Draw a boundary at the end of the headers.
Valid values are nil and `head'.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
"Format as HTML.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
To automatically treat X-PGP-Sig, set it to head.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-treat
:group 'mime-security
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-article-encrypt-protocol "PGP"
"The protocol used for encrypt articles.
It is a string, such as \"PGP\". If nil, ask user."
- :version "21.4"
+ :version "22.1"
:type 'string
:group 'mime-security)
(executable-find idna-program))
"Whether IDNA decoding of headers is used when viewing messages.
This requires GNU Libidn, and by default only enabled if it is found."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-headers
:type 'boolean)
(defcustom gnus-article-over-scroll nil
"If non-nil, allow scrolling the article buffer even when there no more text."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article
:type 'boolean)
;; read-only.
(if (and wash-face-p (memq 'face gnus-article-wash-types))
(gnus-delete-images 'face)
- (let (face faces)
- (save-excursion
+ (let (face faces from)
+ (save-current-buffer
(when (and wash-face-p
- (progn
- (goto-char (point-min))
- (not (re-search-forward "^Face:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^Face:[\t ]*" nil t)))
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
(while (gnus-article-goto-header "Face")
- (setq faces (nconc faces (list (mail-header-field-value)))))))
- (dolist (face faces)
- (let ((png (gnus-convert-face-to-png face))
- image)
- (when png
- (setq image
- (apply 'gnus-create-image png 'png t
- (cdr (assq 'png gnus-face-properties-alist))))
- (gnus-article-goto-header "from")
- (when (bobp)
- (insert "From: [no `from' set]\n")
- (forward-char -17))
- (gnus-add-wash-type 'face)
- (gnus-add-image 'face image)
- (gnus-put-image image nil 'face))))))
- )))
+ (push (mail-header-field-value) faces))))
+ (when faces
+ (goto-char (point-min))
+ (let ((from (gnus-article-goto-header "from"))
+ png image)
+ (unless from
+ (insert "From:")
+ (setq from (point))
+ (insert "[no `from' set]\n"))
+ (while faces
+ (when (setq png (gnus-convert-face-to-png (pop faces)))
+ (setq image
+ (apply 'gnus-create-image png 'png t
+ (cdr (assq 'png gnus-face-properties-alist))))
+ (goto-char from)
+ (gnus-add-wash-type 'face)
+ (gnus-add-image 'face image)
+ (gnus-put-image image nil 'face))))))))))
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
(gnus-delete-images 'xface)
;; Display X-Faces.
(let (x-faces from face)
- (save-excursion
+ (save-current-buffer
(when (and wash-face-p
- (progn
- (goto-char (point-min))
- (not (re-search-forward
- "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^X-Face:[\t ]*" nil t)))
;; If type `W f', use gnus-original-article-buffer,
;; otherwise use the current buffer because displaying
;; RFC822 parts calls this function too.
;; single external face.
(when (stringp gnus-article-x-face-command)
(setq x-faces (list (car x-faces))))
- (while (and (setq face (pop x-faces))
- gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from)))))
- ;; 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))
- (process-kill-without-query
- (start-process
- "article-x-face" nil shell-file-name
- shell-command-switch gnus-article-x-face-command))
- (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)))))))))
+ (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))))))))))
(defun article-decode-mime-words ()
"Decode all MIME-encoded words in the article."
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight header)
+(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."
(interactive (list 'ut t))
- (let* ((header (or header
- (message-fetch-field "date")
- ""))
- (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]")
- (t
- "^Date:[ \t]")))
- (date (if (vectorp header) (mail-header-date header)
- header))
+ (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)
+ (inhibit-read-only t)
(inhibit-point-motion-hooks t)
- pos
- bface eface)
+ pos date bface eface)
(save-excursion
(save-restriction
- (article-narrow-to-head)
- (when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (point-at-bol) 'face)
- date (or (get-text-property (point-at-bol)
- 'original-date)
- date)
- eface (get-text-property (1- (point-at-eol)) 'face))
- (forward-line 1))
- (when (and date (not (string= date "")))
+ (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))
- (let ((inhibit-read-only t))
- ;; 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 "\\([^:]+\\): *\\(.*\\)$")
- (add-text-properties (match-beginning 1) (1+ (match-end 1))
- (list 'original-date date 'face bface))
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))))))))
+ (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))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
- (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)))))
+ (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))))))
(defun gnus-start-date-timer (&optional n)
"Start a timer to update the X-Sent header in the article buffers.
(interactive (list t))
(article-date-ut 'iso8601 highlight))
+(defmacro gnus-article-save-original-date (&rest forms)
+ "Save the original date as a text property and evaluate FORMS."
+ `(let* ((case-fold-search t)
+ (start (progn
+ (goto-char (point-min))
+ (when (and (re-search-forward "^date:[\t\n ]+" nil t)
+ (not (bolp)))
+ (match-end 0))))
+ (date (when (and start
+ (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
+ nil t))
+ (buffer-substring-no-properties start
+ (match-beginning 0)))))
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)
+ ,@forms
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)))
+
;; (defun article-show-all ()
;; "Show all hidden text in the article buffer."
;; (interactive)
\\[gnus-article-describe-briefly]\t Describe the current mode briefly
\\[gnus-info-find-node]\t Go to the Gnus info node"
(interactive)
+ (kill-all-local-variables)
(gnus-simplify-mode-line)
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(make-local-variable 'gnus-article-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
+ ;; Prevent recent Emacsen from displaying non-break space as "\ ".
+ (set (make-local-variable 'nobreak-char-display) nil)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t
show-trailing-whitespace nil)
(set-syntax-table gnus-article-mode-syntax-table)
(mm-enable-multibyte)
- (gnus-run-hooks 'gnus-article-mode-hook))
+ (gnus-run-mode-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(mm-enable-multibyte)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
- (if (get-buffer name)
+ (if (and (get-buffer name)
+ (with-current-buffer name
+ (if gnus-article-edit-mode
+ (if (y-or-n-p "Article mode edit in progress; discard? ")
+ (progn
+ (set-buffer-modified-p nil)
+ (gnus-kill-buffer name)
+ (message "")
+ nil)
+ (error "Action aborted"))
+ t)))
(save-excursion
(set-buffer name)
- (when (and gnus-article-edit-mode
- (buffer-modified-p)
- (not
- (y-or-n-p "Article mode edit in progress; discard? ")))
- (error "Action aborted"))
(set (make-local-variable 'gnus-article-edit-mode) nil)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
and `gnus-mime-delete-part', and not provided at run-time normally."
(gnus-article-edit-article
`(lambda ()
+ (buffer-disable-undo)
(erase-buffer)
(let ((mail-parse-charset (or gnus-article-charset
',gnus-newsgroup-charset))
(mm-merge-handles gnus-article-mime-handles handle))
(gnus-mm-display-part handle))))
-(eval-when-compile
- (require 'jka-compr))
-
-;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days
-;; emacs can do that itself.
-;;
-(defun gnus-mime-jka-compr-maybe-uncompress ()
- "Uncompress the current buffer if `auto-compression-mode' is enabled.
-The uncompress method used is derived from `buffer-file-name'."
- (when (and (fboundp 'jka-compr-installed-p)
- (jka-compr-installed-p))
- (let ((info (jka-compr-get-compression-info buffer-file-name)))
- (when info
- (let ((basename (file-name-nondirectory buffer-file-name))
- (args (jka-compr-info-uncompress-args info))
- (prog (jka-compr-info-uncompress-program info))
- (message (jka-compr-info-uncompress-message info))
- (err-file (jka-compr-make-temp-name)))
- (if message
- (message "%s %s..." message basename))
- (unwind-protect
- (unless (memq (apply 'call-process-region
- (point-min) (point-max)
- prog
- t (list t err-file) nil
- args)
- jka-compr-acceptable-retval-list)
- (jka-compr-error prog args basename message err-file))
- (jka-compr-delete-temp-file err-file)))))))
-
-(defun gnus-mime-copy-part (&optional handle)
+(defun gnus-mime-copy-part (&optional handle arg)
"Put the MIME part under point into a new buffer.
If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
are decompressed."
- (interactive)
+ (interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (contents (and handle (mm-get-part handle)))
- (base (and handle
- (file-name-nondirectory
- (or
- (mail-content-type-get (mm-handle-type handle) 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)
- "*decoded*"))))
- (buffer (and base (generate-new-buffer base))))
- (when contents
- (switch-to-buffer buffer)
- (insert contents)
+ (unless handle
+ (setq handle (get-text-property (point) 'gnus-data)))
+ (when handle
+ (let ((filename (or (mail-content-type-get (mm-handle-disposition handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)))
+ contents dont-decode charset coding-system)
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ (setq contents (or (condition-case nil
+ (mm-decompress-buffer filename nil 'sig)
+ (error
+ (setq dont-decode t)
+ nil))
+ (buffer-string))))
+ (setq filename (cond (filename (file-name-nondirectory filename))
+ (dont-decode "*raw data*")
+ (t "*decoded*")))
+ (cond
+ (dont-decode)
+ ((not arg)
+ (unless (setq charset (mail-content-type-get
+ (mm-handle-type handle) 'charset))
+ (unless (setq coding-system (mm-with-unibyte-buffer
+ (insert contents)
+ (mm-find-buffer-file-coding-system)))
+ (setq charset gnus-newsgroup-charset))))
+ ((numberp arg)
+ (setq charset (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: ")))))
+ (switch-to-buffer (generate-new-buffer filename))
+ (if (or coding-system
+ (and charset
+ (setq coding-system (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii))))
+ (progn
+ (mm-enable-multibyte)
+ (insert (mm-decode-coding-string contents coding-system))
+ (setq buffer-file-coding-system
+ (if (boundp 'last-coding-system-used)
+ (symbol-value 'last-coding-system-used)
+ coding-system)))
+ (mm-disable-multibyte)
+ (insert contents)
+ (setq buffer-file-coding-system mm-binary-coding-system))
;; We do it this way to make `normal-mode' set the appropriate mode.
(unwind-protect
(progn
- (setq buffer-file-name (expand-file-name base))
- (gnus-mime-jka-compr-maybe-uncompress)
+ (setq buffer-file-name (expand-file-name filename))
(normal-mode))
(setq buffer-file-name nil))
(goto-char (point-min)))))
(ps-despool filename)))))
(defun gnus-mime-inline-part (&optional handle arg)
- "Insert the MIME part under point into the current buffer."
+ "Insert the MIME part under point into the current buffer.
+Compressed files like .gz and .bz2 are decompressed."
(interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- contents charset
- (b (point))
- (inhibit-read-only t))
- (when handle
+ (unless handle
+ (setq handle (get-text-property (point) 'gnus-data)))
+ (when handle
+ (let ((b (point))
+ (inhibit-read-only t)
+ contents charset coding-system)
(if (and (not arg) (mm-handle-undisplayer handle))
(mm-remove-part handle)
- (setq contents (mm-get-part handle))
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ (setq contents
+ (or (mm-decompress-buffer
+ (or (mail-content-type-get (mm-handle-disposition handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename))
+ nil t)
+ (buffer-string))))
(cond
((not arg)
- (setq charset (or (mail-content-type-get
- (mm-handle-type handle) 'charset)
- gnus-newsgroup-charset)))
+ (unless (setq charset (mail-content-type-get
+ (mm-handle-type handle) 'charset))
+ (unless (setq coding-system
+ (mm-with-unibyte-buffer
+ (insert contents)
+ (mm-find-buffer-file-coding-system)))
+ (setq charset gnus-newsgroup-charset))))
((numberp arg)
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(setq charset
(or (cdr (assq arg
gnus-summary-show-article-charset-alist))
- (mm-read-coding-system "Charset: ")))))
+ (mm-read-coding-system "Charset: "))))
+ (t
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))))
(forward-line 2)
- (mm-insert-inline handle
- (if (and charset
- (setq charset (mm-charset-to-coding-system
- charset))
- (not (eq charset 'ascii)))
- (mm-decode-coding-string contents charset)
- contents))
+ (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)))
(goto-char b)))))
(defun gnus-mime-view-part-as-charset (&optional handle arg)
(set-window-point window point)))
(let ((handles ihandles)
(inhibit-read-only t)
- handle name type b e display)
+ handle)
(cond (handles)
((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
(when gnus-article-emulate-mime
(save-restriction
(article-goto-body)
(narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (gnus-article-save-original-date
+ (gnus-treat-article 'head)))))))))
(defcustom gnus-mime-display-multipart-as-mixed nil
"Display \"multipart\" parts as \"multipart/mixed\".
(defcustom gnus-mime-display-multipart-alternative-as-mixed nil
"Display \"multipart/alternative\" parts as \"multipart/mixed\"."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-mime
:type 'boolean)
If displaying \"text/html\" is discouraged \(see
`mm-discouraged-alternatives'\) images or other material inside a
\"multipart/related\" part might be overlooked when this variable is nil."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-mime
:type 'boolean)
(goto-char (point-min))
(gnus-insert-prev-page-button)))
(when (and (gnus-visual-p 'page-marker)
- (< (+ (point-max) 2) (buffer-size)))
+ (< (point-max) (save-restriction (widen) (point-max))))
(save-excursion
(goto-char (point-max))
(gnus-insert-next-page-button))))))
(when (eq win (selected-window))
(setq new-sum-point (point)
new-sum-start (window-start win)
- new-sum-hscroll (window-hscroll win))
+ new-sum-hscroll (window-hscroll win)))
(when (eq in-buffer (current-buffer))
(setq selected (gnus-summary-select-article))
(set-buffer obuf)
new-sum-point)
(set-window-point win new-sum-point)
(set-window-start win new-sum-start)
- (set-window-hscroll win new-sum-hscroll)))))
+ (set-window-hscroll win new-sum-hscroll))))
(set-window-configuration owin)
(ding))))))
(defcustom gnus-button-valid-fqdn-regexp
message-valid-fqdn-regexp
"Regular expression that matches a valid FQDN."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type 'regexp)
"Function to use for displaying man pages.
The function must take at least one argument with a string naming the
man page."
- :version "21.4"
+ :version "22.1"
:type '(choice (function-item :tag "Man" manual-entry)
(function-item :tag "Woman" woman)
(function :tag "Other"))
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 "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type '(choice (const "http://www.tex.ac.uk/tex-archive/")
(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 "21.4"
+ :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 "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type '(choice (const "^/?tex-archive/\\|/")
(regexp :tag "Other")))
"\\)")
"Regular expression for ctan directories.
It should match all directories in the top level of `gnus-ctan-url'."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type 'regexp)
gnus-button-valid-fqdn-regexp
">?\\)\\b")
"Regular expression that matches a message ID or a mail address."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type 'regexp)
symbol `ask', always query the user what do do. If it is a function, this
function will be called with the string as it's only argument. The function
must return `mid', `mail', `invalid' or `ask'."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type '(choice (function-item :tag "Heuristic function"
gnus-button-mid-or-mail-heuristic)
A negative RATE indicates a message IDs, whereas a positive indicates a mail
address. The REGEXP is processed with `case-fold-search' set to nil."
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type '(repeat (cons (number :tag "Rate")
(regexp :tag "Regexp"))))
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 "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
specific groups. Setting it higher in Unix 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 "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
specific groups. Setting it higher in Emacs or Gnus related 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 "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
The higher the number, the more buttons will appear and the more false
positives are possible."
;; mail addresses, MIDs, URLs for news, ...
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type 'integer)
The higher the number, the more buttons will appear and the more false
positives are possible."
;; stuff handled by `browse-url' or `gnus-button-embedded-url'
- :version "21.4"
+ :version "22.1"
:group 'gnus-article-buttons
:type 'integer)
("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
1 (>= gnus-button-message-level 0) gnus-button-reply 1)
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
- 0 (>= gnus-button-message-level 0) gnus-button-mailto 0)
+ 0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
0 (>= gnus-button-browse-level 0) browse-url 0)
("^Subject:" gnus-button-url-regexp
(defun gnus-article-highlight-signature ()
"Highlight the signature in an article.
It does this by highlighting everything after
-`gnus-signature-separator' using `gnus-signature-face'."
+`gnus-signature-separator' using the face `gnus-signature'."
(interactive)
(gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t))
(cons fun args)))))))
(defun gnus-parse-news-url (url)
- (let (scheme server group message-id articles)
+ (let (scheme server port group message-id articles)
(with-temp-buffer
(insert url)
(goto-char (point-min))
(when (looking-at "\\([A-Za-z]+\\):")
(setq scheme (match-string 1))
(goto-char (match-end 0)))
- (when (looking-at "//\\([^/]+\\)/")
+ (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
(setq server (match-string 1))
+ (setq port (if (stringp (match-string 3))
+ (string-to-number (match-string 3))
+ (match-string 3)))
(goto-char (match-end 0)))
(cond
(setq group (match-string 1)))
(t
(error "Unknown news URL syntax"))))
- (list scheme server group message-id articles)))
+ (list scheme server port group message-id articles)))
(defun gnus-button-handle-news (url)
"Fetch a news URL."
- (destructuring-bind (scheme server group message-id articles)
+ (destructuring-bind (scheme server port group message-id articles)
(gnus-parse-news-url url)
(cond
(message-id
(save-excursion
(set-buffer gnus-summary-buffer)
(if server
- (let ((gnus-refer-article-method (list (list 'nntp server))))
+ (let ((gnus-refer-article-method
+ (nconc (list (list 'nntp server))
+ gnus-refer-article-method))
+ (nntp-port-number (or port "nntp")))
+ (gnus-message 7 "Fetching %s with %s"
+ message-id gnus-refer-article-method)
(gnus-summary-refer-article message-id))
(gnus-summary-refer-article message-id))))
(group
(if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
(gnus-info-find-node
(concat "("
- (gnus-url-unhex-string
+ (gnus-url-unhex-string
(match-string 1 url))
")"
- (or (gnus-url-unhex-string
+ (or (gnus-url-unhex-string
(match-string 2 url))
"Top")))
(error "Can't parse %s" url)))
(match-string 3 address)
"nntp")))
nil nil nil
- (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
+ (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
current-prefix-arg))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(unless func
- (error (format "Can't find the encrypt protocol %s" protocol)))
+ (error "Can't find the encrypt protocol %s" protocol))
(if (member gnus-newsgroup-name '("nndraft:delayed"
"nndraft:drafts"
"nndraft:queue"))
projects / gnus / blobdiff