;;; gnus-art.el --- article mode commands for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
: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'
: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)
: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)
(make-obsolete-variable 'gnus-treat-display-xface
- 'gnus-treat-display-x-face)
+ 'gnus-treat-display-x-face "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")
(let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
w3m-force-redisplay)
(w3m-region (point-min) (point-max)))
+ ;; Put the mark meaning this part was rendered by emacs-w3m.
+ (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t)
(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))))
+ (if (and (boundp 'w3m-link-map)
+ w3m-link-map)
+ (let* ((start (point-min))
+ (end (point-max))
+ (on (get-text-property start 'w3m-href-anchor))
+ (map (copy-keymap w3m-link-map))
+ next)
+ (set-keymap-parent map w3m-minor-mode-map)
+ (while (< start end)
+ (if on
+ (progn
+ (setq next (or (text-property-any start end
+ 'w3m-href-anchor nil)
+ end))
+ (put-text-property start next 'keymap map))
+ (setq next (or (text-property-not-all start end
+ 'w3m-href-anchor nil)
+ end))
+ (put-text-property start next 'keymap w3m-minor-mode-map))
+ (setq start next
+ on (not on))))
+ (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map))))
(defvar charset) ;; Bound by `article-wash-html'.
(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)))
+ (narrow-to-region
+ pos (if (setq pos (text-property-any pos (point-max)
+ 'original-date nil))
+ (progn
+ (goto-char pos)
+ (if (or (bolp) (eobp))
+ (point)
+ (1+ (point))))
+ (point-max)))
(goto-char (point-min))
(when (re-search-forward tdate-regexp nil t)
(setq bface (get-text-property (point-at-bol) 'face)
(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)
(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)
(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)
- "Pipe this article to subprocess."
- (let ((save-buffer gnus-save-article-buffer)
- (default (or gnus-summary-pipe-output-default-command
- gnus-last-shell-command)))
- ;; `gnus-save-article-buffer' should be a buffer containing the article
- ;; contents if this function is called by way of the command
- ;; `gnus-summary-pipe-output'. OTOH, that the buffer does not exist
- ;; means this function is called independently.
- (unless (gnus-buffer-live-p save-buffer)
- (let ((article (gnus-summary-article-number))
- (decode (get 'gnus-summary-save-in-pipe :decode)))
- (if article
- (if (vectorp (gnus-summary-article-header article))
- (save-window-excursion
- (let ((gnus-display-mime-function
- (when decode
- gnus-display-mime-function))
- (gnus-article-prepare-hook
- (when decode
- gnus-article-prepare-hook)))
- (gnus-summary-select-article t t nil article)
- (gnus-summary-goto-subject 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.
- (let ((gnus-visible-headers
- (or (symbol-value (get gnus-default-article-saver
- :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"))))
+(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
- (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"))
- default))))
+ (gnus-read-shell-command "Shell command on this article: "
+ default))))
(when (string-equal command "")
(if default
(setq command default)
"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
"\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
(vector (caddr c) (car c) :active t))
gnus-mime-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 ((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."
,gnus-summary-buffer no-highlight))
t)
(gnus-article-edit-done)
- (gnus-summary-expand-window)
- (gnus-summary-show-article)
+ (gnus-configure-windows 'article)
(when (and current-id (integerp gnus-auto-select-part))
- (gnus-article-jump-to-part
- (if (text-property-any (point-min) (point-max)
- 'gnus-part (+ current-id gnus-auto-select-part))
- (+ current-id gnus-auto-select-part)
- (with-current-buffer gnus-article-buffer
- (length gnus-article-mime-handle-alist)))))))
+ (gnus-article-jump-to-part (+ current-id gnus-auto-select-part)))))
(defun gnus-mime-replace-part (file)
"Replace MIME part under point with an external body."
"`----\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)
(mm-string-to-multibyte contents)))
(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
(when (prog1
(and fun
- (setq gnus-newsgroup-charset
+ (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-strip-charset-parameters 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)))
(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\)."
(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))
(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
(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
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)
+ (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))
- (+ (or lines (1- (window-height)))
- (or (and (boundp 'scroll-margin)
- (symbol-value 'scroll-margin))
- 0)))))
+ (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.
(min (max 0 scroll-margin)
(max 1 (- (window-height)
(if mode-line-format 1 0)
- (if header-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))
+ (unless (featurep 'xemacs)
;; 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))))))
+ (when (and (numberp lines)
+ (> lines 0)
+ (> scroll-margin 0))
+ (setq lines (min lines
+ (max 0 (- (count-lines (window-start) (point-max))
+ scroll-margin))))))
(condition-case ()
(let ((scroll-in-place nil))
(scroll-up lines))
(goto-char (point-max))
(recenter (if gnus-article-over-scroll
(if lines
- (max (+ lines (or (and (boundp 'scroll-margin)
- (symbol-value 'scroll-margin))
- 0))
+ (max (if (featurep 'xemacs)
+ lines
+ (+ lines scroll-margin))
3)
(- (window-height) 2))
-1)))
(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)))
-
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
(unless (equal major-mode 'gnus-article-mode)
(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)
(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))
(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)))
+ (key-binding keys t)))
(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)
;;`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)
(defun gnus-article-describe-bindings (&optional prefix)
"Show a list of all defined keys, and their definitions.
(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 draft)
+ 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
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>
(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."
(when (and gnus-article-encrypt-protocol
gnus-novice-user)
(unless (gnus-y-or-n-p "Really encrypt article(s)? ")
- (error "Encrypt aborted.")))
+ (error "Encrypt aborted")))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(unless func
(error "Can't find the encrypt protocol %s" protocol))