;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(eval-when-compile (require 'cl))
-(require 'custom)
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
-(require 'browse-url)
(require 'mm-bodies)
(require 'mail-parse)
(require 'mm-decode)
(const :tag "Followup-to identical to newsgroups." followup-to)
(const :tag "Reply-to identical to from." reply-to)
(const :tag "Date less than four days old." date)
- (const :tag "Very long To header." long-to)
- (const :tag "Multiple To headers." many-to))
+ (const :tag "Very long To and/or Cc header." long-to)
+ (const :tag "Multiple To and/or Cc headers." many-to))
:group 'gnus-article-hiding)
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
:group 'gnus-article-hiding)
(defcustom gnus-article-x-face-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"
+ (if (and (fboundp 'image-type-available-p)
+ (or (image-type-available-p 'xpm)
+ (image-type-available-p 'xbm)))
+ 'gnus-article-display-xface
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -")
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
- :type 'string ;Leave function case to Lisp.
+ :type '(choice string
+ (function-item gnus-article-display-xface)
+ function)
:group 'gnus-article-washing)
(defcustom gnus-article-x-face-too-ugly nil
4))
(gnus-article-hide-header "date"))))
((eq elem 'long-to)
- (let ((to (message-fetch-field "to")))
+ (let ((to (message-fetch-field "to"))
+ (cc (message-fetch-field "cc")))
(when (> (length to) 1024)
- (gnus-article-hide-header "to"))))
+ (gnus-article-hide-header "to"))
+ (when (> (length cc) 1024)
+ (gnus-article-hide-header "cc"))))
((eq elem 'many-to)
- (let ((to-count 0))
+ (let ((to-count 0)
+ (cc-count 0))
(goto-char (point-min))
(while (re-search-forward "^to:" nil t)
(setq to-count (1+ to-count)))
(forward-line -1)
(narrow-to-region (point) (point-max))
(gnus-article-hide-header "to"))
- (setq to-count (1- to-count)))))))))))))
+ (setq to-count (1- to-count))))
+ (goto-char (point-min))
+ (while (re-search-forward "^cc:" nil t)
+ (setq cc-count (1+ cc-count)))
+ (when (> cc-count 1)
+ (while (> cc-count 0)
+ (goto-char (point-min))
+ (save-restriction
+ (re-search-forward "^cc:" nil nil cc-count)
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (gnus-article-hide-header "cc"))
+ (setq cc-count (1- cc-count)))))))))))))
(defun gnus-article-hide-header (header)
(save-excursion
"Decode charset-encoded text in the article.
If PROMPT (the prefix), prompt for a coding system to use."
(interactive "P")
+ (let ((inhibit-point-motion-hooks t) (case-fold-search t)
+ buffer-read-only
+ (mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets
+ (save-excursion (condition-case nil
+ (set-buffer gnus-summary-buffer)
+ (error))
+ gnus-newsgroup-ignored-charsets))
+ ct cte ctl charset)
(save-excursion
(save-restriction
(article-narrow-to-head)
- (let* ((inhibit-point-motion-hooks t)
- (case-fold-search t)
- (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))))
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (condition-case nil
- (set-buffer gnus-summary-buffer)
- (error))
- gnus-newsgroup-ignored-charsets))
- buffer-read-only)
- (if (and ctl (not (string-match "/" (car ctl))))
- (setq ctl nil))
- (goto-char (point-max))
- (widen)
- (forward-line 1)
- (narrow-to-region (point) (point-max))
- (when (and (or (not ctl)
- (equal (car ctl) "text/plain")))
- (mm-decode-body
- charset (and cte (intern (downcase
- (gnus-strip-whitespace cte))))
- (car ctl)))))))
+ (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))))
+ (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 (or (not ctl)
+ (equal (car ctl) "text/plain")))
+ (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."
"Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
or not."
+ (interactive (list 'force))
+ (save-excursion
+ (let ((buffer-read-only nil)
+ (type (gnus-fetch-field "content-transfer-encoding"))
+ (charset gnus-newsgroup-charset))
+ (when (or force
+ (and type (string-match "quoted-printable" (downcase type))))
+ (article-goto-body)
+ (quoted-printable-decode-region (point) (point-max) charset)))))
+
+(defun article-de-base64-unreadable (&optional force)
+ "Translate a base64 article.
+If FORCE, decode the article whether it is marked as base64 not."
(interactive (list 'force))
(save-excursion
(let ((buffer-read-only nil)
(article-goto-body)
(save-restriction
(narrow-to-region (point) (point-max))
- (quoted-printable-decode-region (point-min) (point-max))
- (when charset
- (mm-decode-body charset)))))))
+ (base64-decode-region (point-min) (point-max))
+ (if (mm-coding-system-p charset)
+ (mm-decode-coding-region (point-min) (point-max) charset)))))))
+
+(eval-when-compile
+ (require 'rfc1843))
+
+(defun article-decode-HZ ()
+ "Translate a HZ-encoded article."
+ (interactive)
+ (require 'rfc1843)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (rfc1843-decode-region (point-min) (point-max)))))
+
+(defun article-wash-html ()
+ "Format an html article."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil)
+ (charset gnus-newsgroup-charset))
+ (article-goto-body)
+ (save-window-excursion
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (mm-setup-w3)
+ (let ((w3-strict-width (window-width))
+ (url-standalone-mode t))
+ (condition-case var
+ (w3-region (point-min) (point-max))
+ (error))))))))
(defun article-hide-list-identifiers ()
"Remove list identifies from the Subject header.
(while (setq elem (pop alist))
(when (and name (string-match (car elem) name))
(setq alist nil
- highlight (copy-list (cdr elem)))))
+ highlight (copy-sequence (cdr elem)))))
highlight)
- (copy-list highlight-words)
+ (copy-sequence highlight-words)
(if gnus-newsgroup-name
- (copy-list (gnus-group-find-parameter
- gnus-newsgroup-name 'highlight-words t)))
+ (copy-sequence (gnus-group-find-parameter
+ gnus-newsgroup-name 'highlight-words t)))
gnus-emphasis-alist)))))
(defvar gnus-summary-article-menu)
article-remove-cr
article-display-x-face
article-de-quoted-unreadable
+ article-de-base64-unreadable
+ article-decode-HZ
+ article-wash-html
article-mime-decode-quoted-printable
article-hide-list-identifiers
article-hide-pgp
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
- "e" gnus-summary-article-edit
+ "e" gnus-summary-edit-article
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
["Hide citation" gnus-article-hide-citation t]
["Treat overstrike" gnus-article-treat-overstrike t]
["Remove carriage return" gnus-article-remove-cr t]
- ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]))
+ ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
+ ["Remove base64" gnus-article-de-base64-unreadable t]
+ ["Treat html" gnus-article-wash-html t]
+ ["Decode HZ" gnus-article-decode-HZ t]))
;; Note "Commands" menu is defined in gnus-sum.el for consistency
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
- (make-local-variable 'gnus-article-washed-types)
+ (make-local-variable 'gnus-article-wash-types)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t)
(if (get-buffer name)
(save-excursion
(set-buffer name)
- (if gnus-article-mime-handles
- (mm-destroy-parts gnus-article-mime-handles))
- (kill-all-local-variables)
+ (when gnus-article-mime-handles
+ (mm-destroy-parts gnus-article-mime-handles))
(buffer-disable-undo)
(setq buffer-read-only t)
(unless (eq major-mode 'gnus-article-mode)
(message "Message marked for downloading"))
(gnus-summary-mark-article article gnus-canceled-mark)
(unless (memq article gnus-newsgroup-sparse)
- (gnus-error 1
- "No such article (may have expired or been canceled)")))))
+ (gnus-error 1 "No such article (may have expired or been canceled)")))))
(if (or (eq result 'pseudo)
(eq result 'nneething))
(progn
(cons (caddr c) (car c)))
gnus-mime-button-commands))))))
(if response
- (funcall response))))))
+ (call-interactively response))))))
(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
(let ((data (get-text-property (point) 'gnus-data)))
(mm-interactively-view-part data)))
-(defun gnus-mime-view-part-as-type ()
+(defun gnus-mime-view-part-as-type-internal ()
+ (gnus-article-check-buffer)
+ (let* ((name (mail-content-type-get
+ (mm-handle-type (get-text-property (point) 'gnus-data))
+ 'name))
+ (def-type (and name (mm-default-file-encoding name))))
+ (and def-type (cons def-type 0))))
+
+(defun gnus-mime-view-part-as-type (mime-type)
"Choose a MIME media type, and view the part as such."
(interactive
- (list (completing-read "View as MIME type: " mailcap-mime-types)))
+ (list (completing-read
+ "View as MIME type: "
+ (mapcar (lambda (i) (list i i)) (mailcap-mime-types))
+ nil nil
+ (gnus-mime-view-part-as-type-internal))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
- (gnus-mm-display-part handle)))
+ (gnus-mm-display-part
+ (mm-make-handle (mm-handle-buffer handle)
+ (cons mime-type (cdr (mm-handle-type handle)))
+ (mm-handle-encoding handle)
+ (mm-handle-undisplayer handle)
+ (mm-handle-disposition handle)
+ (mm-handle-description handle)
+ (mm-handle-cache handle)
+ (mm-handle-id handle)))))
(defun gnus-mime-copy-part (&optional handle)
"Put the the MIME part under point into a new buffer."
(narrow-to-region (point) (point-max))
(gnus-treat-article nil 1 1)
(widen)))
- (if (not ihandles)
- ;; Highlight the headers.
- (save-excursion
- (save-restriction
- (article-goto-body)
- (narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (unless ihandles
+ ;; Highlight the headers.
+ (save-excursion
+ (save-restriction
+ (article-goto-body)
+ (narrow-to-region (point-min) (point))
+ (gnus-treat-article 'head))))))))
(defvar gnus-mime-display-multipart-as-mixed nil)
(push (cons id handle) gnus-article-mime-handle-alist)
(when (or (not display)
(not (gnus-unbuttonized-mime-type-p type)))
- (gnus-article-insert-newline)
+ ;(gnus-article-insert-newline)
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
- (gnus-article-insert-newline)
+ ;(gnus-article-insert-newline)
(setq move t)))
(let ((beg (point)))
(cond
;; We disable the pick minor mode commands.
(let (gnus-pick-mode)
(setq func (lookup-key (current-local-map) keys))))
- (if (not func)
+ (if (or (not func)
+ (numberp func))
(ding)
(unless (member keys nosave-in-article)
(set-buffer gnus-article-current-summary))
;; We only request an article by message-id when we do not have the
;; headers for it, so we'll have to get those.
(when (stringp article)
- (let ((gnus-override-method gnus-refer-article-method))
- (gnus-read-header article)))
+ (gnus-read-header article))
;; If the article number is negative, that means that this article
;; doesn't belong in this newsgroup (possibly), so we find its
;; This is a sparse gap article.
(setq do-update-line article)
(setq article (mail-header-id header))
- (let ((gnus-override-method gnus-refer-article-method))
- (setq sparse-header (gnus-read-header article)))
+ (setq sparse-header (gnus-read-header article))
(setq gnus-newsgroup-sparse
(delq article gnus-newsgroup-sparse)))
((vectorp header)
(gnus-cache-request-article article group))
'article)
;; Get the article and put into the article buffer.
- ((or (stringp article) (numberp article))
- (let ((gnus-override-method
- (and (stringp article) gnus-refer-article-method))
+ ((or (stringp article)
+ (numberp article))
+ (let ((gnus-override-method gnus-override-method)
+ (methods (and (stringp article)
+ gnus-refer-article-method))
+ result
(buffer-read-only nil))
- (erase-buffer)
- (gnus-kill-all-overlays)
- (let ((gnus-newsgroup-name group))
- (gnus-check-group-server))
- (when (gnus-request-article article group (current-buffer))
- (when (numberp article)
- (gnus-async-prefetch-next group article gnus-summary-buffer)
- (when gnus-keep-backlog
- (gnus-backlog-enter-article
- group article (current-buffer))))
- 'article)))
+ (setq methods
+ (if (listp methods)
+ methods
+ (list methods)))
+ (when (and (null gnus-override-method)
+ methods)
+ (setq gnus-override-method (pop methods)))
+ (while (not result)
+ (when (eq gnus-override-method 'current)
+ (setq gnus-override-method gnus-current-select-method))
+ (erase-buffer)
+ (gnus-kill-all-overlays)
+ (let ((gnus-newsgroup-name group))
+ (gnus-check-group-server))
+ (when (gnus-request-article article group (current-buffer))
+ (when (numberp article)
+ (gnus-async-prefetch-next group article
+ gnus-summary-buffer)
+ (when gnus-keep-backlog
+ (gnus-backlog-enter-article
+ group article (current-buffer))))
+ (setq result 'article))
+ (if (not result)
+ (if methods
+ (setq gnus-override-method (pop methods))
+ (setq result 'done))))
+ (and (eq result 'article) 'article)))
;; It was a pseudo.
(t article)))
;;; Internal Variables:
-(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"
+(defcustom gnus-button-url-regexp "\\b\\(\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)\\|[-a-zA-Z0-9_]+\\.[-a-zA-Z0-9_]+\\(\\.[-a-zA-Z0-9_]+[-a-zA-Z0-9_/]+\\)+"
"Regular expression that matches URLs."
:group 'gnus-article-buttons
:type 'regexp)
("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1)
("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
;; This is how URLs _should_ be embedded in text...
- ("<URL: *\\([^>]*\\)>" 0 t gnus-button-embedded-url 1)
+ ("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
;; Raw URLs.
(,gnus-button-url-regexp 0 t browse-url 0))
"*Alist of regexps matching buttons in article bodies.
(eq gnus-newsgroup-name
(car gnus-decode-header-methods-cache)))
(setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
- (mapc '(lambda (x)
- (if (symbolp x)
- (nconc gnus-decode-header-methods-cache (list x))
- (if (and gnus-newsgroup-name
- (string-match (car x) gnus-newsgroup-name))
- (nconc gnus-decode-header-methods-cache
- (list (cdr x))))))
+ (mapcar (lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
gnus-decode-header-methods))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
val elem)
(gnus-run-hooks 'gnus-part-display-hook)
(while (setq elem (pop alist))
- (setq val (symbol-value (car elem)))
+ (setq val
+ (save-excursion
+ (if (gnus-buffer-live-p gnus-summary-buffer)
+ (set-buffer gnus-summary-buffer))
+ (symbol-value (car elem))))
(when (and (or (consp val)
treated-type)
(gnus-treat-predicate val)
projects / gnus / blobdiff