;;; 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.
+;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;;; Code:
+;; For Emacs < 22.2.
+(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.
(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
(mm-coding-system-p 'utf-8)
- (executable-find (symbol-value 'idna-program)))
+ (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 "22.1"
(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'."
(forward-line 1)
(point))))))
-(eval-when-compile
- (defvar gnus-face-properties-alist))
+(defvar gnus-face-properties-alist)
(defun article-display-face (&optional force)
"Display any Face headers in the header."
(t
(apply (car func) (cdr func))))))))))
+;; External.
+(declare-function w3-region "ext:w3-display" (st nd))
+
(defun gnus-article-wash-html-with-w3 ()
"Wash the current buffer with w3."
(mm-setup-w3)
(w3-region (point-min) (point-max))
(error))))
+;; External.
+(declare-function w3m-region "ext:w3m" (start end &optional url charset))
+
(defun gnus-article-wash-html-with-w3m ()
"Wash the current buffer with emacs-w3m."
(mm-setup-w3m)
;; 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'.
+(defvar charset) ;; Bound by `article-wash-html'.
(defun gnus-article-wash-html-with-w3m-standalone ()
"Wash the current buffer with w3m."
(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)))
+ (gnus-y-or-n-p (format
+ "Delete all %s temporary HTML file(s)? "
+ (length gnus-article-browse-html-temp-list)))
(setq how t)))
(dolist (file gnus-article-browse-html-temp-list)
(when (and (file-exists-p file)
(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-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 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"))))
+ (when (or (setq charset (mail-content-type-get type '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)
+ (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 (mm-get-part handle)
+ charset))
+ (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 (mm-get-part handle))
+ (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
+ (mm-get-part handle) body)
+ charset))))
+ (setq charset hcharset
+ eheader (mm-encode-coding-string
+ (buffer-string) coding)
+ title (when title
+ (mm-encode-coding-string
+ title coding))
+ body (mm-get-part handle)))
+ (setq eheader (mm-string-as-unibyte (buffer-string))
+ body (mm-get-part handle))))
+ (erase-buffer)
+ (mm-disable-multibyte)
+ (insert body)
+ (when charset
+ (mm-add-meta-html-tag handle 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
+ (mm-get-part handle)
+ (setq charset 'utf-8))
+ (mm-get-part handle)))
+ (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.
+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 in HTML articles to verify
whether you have read the message. As
If you alwasy want to display HTML part in the browser, set
`mm-text-html-renderer' to nil."
;; 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)))
+ (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.
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.
(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
"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
"\C-d" 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))
(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))
"| Type: " type "\n"
"| Filename: " filename "\n"
"| Size (encoded): " bsize " Byte\n"
- "| Description: " description "\n"
+ (when description
+ (concat "| Description: " description "\n"))
"`----\n"))
(setcdr data
(cdr (mm-make-handle
"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)
(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))
(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)
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-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))
+ (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)
+ (if (memq (key-binding key t) '(gnus-article-read-summary-keys
+ gnus-article-read-summary-send-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))
+ (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)
+
+(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))
+ agent)
+ (define-key keymap "S" map)
+ (define-key map [t] nil)
+ (with-current-buffer gnus-article-current-summary
+ (set-keymap-parent map (key-binding "S"))
+ (let (def gnus-pick-mode)
+ (dolist (key sumkeys)
+ (when (setq def (key-binding key))
+ (define-key keymap key def))))
+ (when (boundp 'gnus-agent-summary-mode)
+ (setq agent gnus-agent-summary-mode)))
+ (with-temp-buffer
+ (use-local-map keymap)
+ (set (make-local-variable 'gnus-agent-summary-mode) agent)
+ (describe-bindings prefix))
+ (let ((item `((lambda (prefix)
+ (save-excursion
+ (set-buffer ,(current-buffer))
+ (gnus-article-describe-bindings prefix)))
+ ,prefix)))
+ (with-current-buffer (if (fboundp 'help-buffer)
+ (let (help-xref-following) (help-buffer))
+ "*Help*") ;; Emacs 21
+ (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,
"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))
+
(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'.
(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 type)
+(defvar condition)
+(defvar length)
(defun gnus-treat-predicate (val)
(cond
gnus-article-encrypt-protocol-alist
nil 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))
projects / gnus / blobdiff