;;; gnus-art.el --- article mode commands for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(autoload 'gnus-button-reply "gnus-msg" nil t)
(autoload 'parse-time-string "parse-time" nil nil)
(autoload 'ansi-color-apply-on-region "ansi-color")
+(autoload 'mm-url-insert-file-contents-external "mm-url")
(defgroup gnus-article nil
"Article display."
This can also be a list of regexps. In that case, it will be checked
from head to tail looking for a separator. Searches will be done from
the end of the buffer."
- :type '(repeat string)
+ :type '(choice :format "%{%t%}: %[Value Menu%]\n%v"
+ (regexp)
+ (repeat :tag "List of regexp" regexp))
:group 'gnus-article-signature)
(defcustom gnus-signature-limit nil
(function-item gnus-summary-save-in-file)
(function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
- (function-item gnus-summary-write-to-file)))
+ (function-item gnus-summary-write-to-file)
+ (function)))
(defcustom gnus-rmail-save-name 'gnus-plain-save-name
"A function generating a file name to save articles in Rmail format.
(make-obsolete-variable 'gnus-article-hide-pgp-hook
"This variable is obsolete in Gnus 5.10.")
-(defcustom gnus-article-button-face 'bold
+(defface gnus-button
+ '((t :weight bold))
+ "Face used for highlighting a button in the article buffer."
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-article-button-face 'gnus-button
"Face used for highlighting buttons in the article buffer.
An article button is a piece of text that you can activate by pressing
"Delete text of TYPE in the current buffer."
(save-excursion
(let ((b (point-min)))
- (while (setq b (text-property-any b (point-max) 'article-type type))
- (delete-region
- b (or (text-property-not-all b (point-max) 'article-type type)
- (point-max)))))))
+ (if (eq type 'multipart)
+ ;; Remove MIME buttons associated with multipart/alternative parts.
+ (progn
+ (goto-char b)
+ (while (if (get-text-property (point) 'gnus-part)
+ (setq b (point))
+ (when (setq b (next-single-property-change (point)
+ 'gnus-part))
+ (goto-char b)
+ t))
+ (end-of-line)
+ (skip-chars-forward "\n")
+ (when (eq (get-text-property b 'article-type) 'multipart)
+ (delete-region b (point)))))
+ (while (setq b (text-property-any b (point-max) 'article-type type))
+ (delete-region
+ b (or (text-property-not-all b (point-max) 'article-type type)
+ (point-max))))))))
(defun gnus-article-delete-invisible-text ()
"Delete all invisible text in the current buffer."
(error))
gnus-newsgroup-ignored-charsets))
ct cte ctl charset format)
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (setq ct (message-fetch-field "Content-Type" t)
- cte (message-fetch-field "Content-Transfer-Encoding" t)
- ctl (and ct (ignore-errors
- (mail-header-parse-content-type ct)))
- charset (cond
- (prompt
- (mm-read-coding-system "Charset to decode: "))
- (ctl
- (mail-content-type-get ctl 'charset)))
- format (and ctl (mail-content-type-get ctl 'format)))
- (when cte
- (setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
- (setq ctl nil))
- (goto-char (point-max)))
- (forward-line 1)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (when (and (eq mail-parse-charset 'gnus-decoded)
- (eq (mm-body-7-or-8) '8bit))
- ;; The text code could have been decoded.
- (setq charset mail-parse-charset))
- (when (and (or (not ctl)
- (equal (car ctl) "text/plain"))
- (not format)) ;; article with format will decode later.
- (mm-decode-body
- charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))
- (car ctl)))))))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (setq ct (message-fetch-field "Content-Type" t)
+ cte (message-fetch-field "Content-Transfer-Encoding" t)
+ ctl (and ct (mail-header-parse-content-type ct))
+ charset (cond
+ (prompt
+ (mm-read-coding-system "Charset to decode: "))
+ (ctl
+ (mail-content-type-get ctl 'charset)))
+ format (and ctl (mail-content-type-get ctl 'format)))
+ (when cte
+ (setq cte (mail-header-strip cte)))
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
+ (goto-char (point-max)))
+ (forward-line 1)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (when (and (eq mail-parse-charset 'gnus-decoded)
+ (eq (mm-body-7-or-8) '8bit))
+ ;; The text code could have been decoded.
+ (setq charset mail-parse-charset))
+ (when (and (or (not ctl)
+ (equal (car ctl) "text/plain"))
+ (not format)) ;; article with format will decode later.
+ (mm-decode-body
+ charset (and cte (intern (downcase
+ (gnus-strip-whitespace cte))))
+ (car ctl)))))))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
- (ignore-errors
- (mail-header-parse-content-type ct)))))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
- (ignore-errors
- (mail-header-parse-content-type ct)))))
+ (ctl (and ct (mail-header-parse-content-type ct))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(defun article-wash-html (&optional read-charset)
"Format an HTML article.
-If READ-CHARSET, ask for a coding system."
+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)
- (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
- (ignore-errors
- (mail-header-parse-content-type ct)))))
- (setq charset (and ctl
- (mail-content-type-get ctl 'charset)))
- (when (stringp charset)
- (setq charset (intern (downcase charset)))))))
- (when read-charset
- (setq charset (mm-read-coding-system "Charset: " charset)))
- (unless charset
- (setq charset gnus-newsgroup-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
(defun gnus-article-wash-html-with-w3m ()
"Wash the current buffer with emacs-w3m."
(mm-setup-w3m)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (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)))))
+ (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 gnus-article-browse-html-parts (list)
+ "View all \"text/html\" parts from LIST.
+Recurse into multiparts."
+ ;; Internal function used by `gnus-article-browse-html-article'.
+ (let ((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)
+ (browse-url 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))))))))
+ showed))
+
+;; TODO: Key binding; Remove temp files.
+(defun gnus-article-browse-html-article ()
+ "View \"text/html\" parts of the current article with a WWW browser."
+ (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)))
+ ;; 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)
+ (gnus-error 3 "Mail doesn't contain a \"text/html\" part!"))
+ (gnus-summary-show-article))))
(defun article-hide-list-identifiers ()
"Remove list identifies from the Subject header.
(article-really-strip-banner
(gnus-parameter-banner gnus-newsgroup-name)))
(when gnus-article-address-banner-alist
- ;; It is necessary to encode from fields before checking,
- ;; because `mail-header-parse-addresses' does not work
- ;; (reliably) on decoded headers. And more, it is
- ;; impossible to use `gnus-fetch-original-field' here,
- ;; because `article-strip-banner' may be called in draft
- ;; buffers to preview them.
+ ;; Note that the From header is decoded here, so it is
+ ;; required that the *-extract-address-components function
+ ;; supports non-ASCII text.
(let ((from (save-restriction
(widen)
(article-narrow-to-head)
(mail-fetch-field "from"))))
(when (and from
(setq from
- (caar (mail-header-parse-addresses
- (mail-encode-encoded-word-string from)))))
+ (cadr (funcall gnus-extract-address-components
+ from))))
(catch 'found
(dolist (pair gnus-article-address-banner-alist)
(when (string-match (car pair) from)
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
- gnus-data ,handle))
+ article-type multipart))
(widget-convert-button 'link from (point)
:action 'gnus-widget-press-button
:button-keymap gnus-widget-button-keymap)
(gnus-url-mailto url-mailto))
(t (gnus-message 3 "Invalid string.")))))
-(defun gnus-button-handle-custom (url)
- "Follow a Custom URL."
- (customize-apropos (gnus-url-unhex-string url)))
+(defun gnus-button-handle-custom (fun arg)
+ "Call function FUN on argument ARG.
+Both FUN and ARG are supposed to be strings. ARG will be passed
+as a symbol to FUN."
+ (funcall (intern fun) (intern arg)))
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
;; Info links like `C-h i d m CC Mode RET'
0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
;; This is custom
- ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)"
- 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
- ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
- (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
+ ("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"
;; regexp doesn't match arguments containing ` '.
(?d gnus-tmp-details ?s)
(?D gnus-tmp-pressed-details ?s)))
+(defvar gnus-mime-security-button-commands
+ '((gnus-article-press-button "\r" "Show Detail")
+ (undefined "v")
+ (undefined "t")
+ (undefined "C")
+ (gnus-mime-security-save-part "o" "Save...")
+ (undefined "\C-o")
+ (undefined "r")
+ (undefined "d")
+ (undefined "c")
+ (undefined "i")
+ (undefined "E")
+ (undefined "e")
+ (undefined "p")
+ (gnus-mime-security-pipe-part "|" "Pipe To Command...")
+ (undefined ".")))
+
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
(define-key map gnus-mouse-2 'gnus-article-push-button)
- (define-key map "\r" 'gnus-article-press-button)
+ (define-key map gnus-down-mouse-3 'gnus-mime-security-button-menu)
+ (dolist (c gnus-mime-security-button-commands)
+ (define-key map (cadr c) (car c)))
map))
+(easy-menu-define
+ gnus-mime-security-button-menu gnus-mime-security-button-map
+ "Security button menu."
+ `("Security Part"
+ ,@(delq nil
+ (mapcar (lambda (c)
+ (unless (eq (car c) 'undefined)
+ (vector (caddr c) (car c) :enable t)))
+ gnus-mime-security-button-commands))))
+
+(defun gnus-mime-security-button-menu (event prefix)
+ "Construct a context-sensitive menu of security commands."
+ (interactive "e\nP")
+ (save-window-excursion
+ (let ((pos (event-start event)))
+ (select-window (posn-window pos))
+ (goto-char (posn-point pos))
+ (gnus-article-check-buffer)
+ (popup-menu gnus-mime-security-button-menu nil prefix))))
+
(defvar gnus-mime-security-details-buffer nil)
(defvar gnus-mime-security-button-pressed nil)
(when (boundp 'help-echo-owns-message)
(setq help-echo-owns-message t))
(format
- "%S: show detail"
- (aref gnus-mouse-2 0))))))
+ "%S: show detail; %S: more options"
+ (aref gnus-mouse-2 0)
+ (aref gnus-down-mouse-3 0))))))
(defun gnus-mime-display-security (handle)
(save-restriction
(cons (set-marker (make-marker) (point-min))
(set-marker (make-marker) (point-max))))))
+(defun gnus-mime-security-run-function (function)
+ "Run FUNCTION with the security part under point."
+ (gnus-article-check-buffer)
+ (let ((data (get-text-property (point) 'gnus-data))
+ buffer handle)
+ (when (and (stringp (car-safe data))
+ (setq buffer (mm-handle-multipart-original-buffer data))
+ (setq handle (cadr data)))
+ (if (bufferp (mm-handle-buffer handle))
+ (progn
+ (setq handle (cons buffer (copy-sequence (cdr handle))))
+ (mm-handle-set-undisplayer handle nil))
+ (setq handle (mm-make-handle
+ buffer
+ (mm-handle-multipart-ctl-parameter handle 'protocol)
+ nil nil nil nil nil nil)))
+ (funcall function handle))))
+
+(defun gnus-mime-security-save-part ()
+ "Save the security part under point."
+ (interactive)
+ (gnus-mime-security-run-function 'mm-save-part))
+
+(defun gnus-mime-security-pipe-part ()
+ "Pipe the security part under point to a process."
+ (interactive)
+ (gnus-mime-security-run-function 'mm-pipe-part))
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / gnus / blobdiff