-;;; gnus-art.el --- article mode commands for Gnus
+;;; gnus-art.el --- article mode commands for Semi-gnus
;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
(require 'gnus-spec)
(require 'gnus-int)
(require 'browse-url)
-(require 'mm-bodies)
-(require 'mail-parse)
-(require 'mm-decode)
-(require 'mm-view)
-(require 'wid-edit)
-(require 'mm-uu)
+(require 'alist)
+(require 'mime-view)
+
+;; Avoid byte-compile warnings.
+(eval-when-compile
+ (defvar gnus-article-decoded-p)
+ (defvar gnus-article-mime-handles)
+ (require 'mm-bodies)
+ (require 'mail-parse)
+ (require 'mm-decode)
+ (require 'mm-view)
+ (require 'wid-edit)
+ (require 'mm-uu)
+ )
(defgroup gnus-article nil
"Article display."
"^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
"^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
"^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
- "^Status:")
+ "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:")
"*All headers that start with this regexp will be hidden.
This variable can also be a list of regexps of headers to be ignored.
If `gnus-visible-headers' is non-nil, this variable will be ignored."
(cons :value ("" "") regexp (repeat string))
(sexp :value nil))))
+(defcustom gnus-article-display-method-for-mime
+ 'gnus-article-display-mime-message
+ "Function to display a MIME message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defcustom gnus-article-display-method-for-traditional
+ 'gnus-article-display-traditional-message
+ "*Function to display a traditional message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
(defcustom gnus-page-delimiter "^\^L"
"*Regexp describing what to use as article page delimiters.
The default value is \"^\^L\", which is a form linefeed at the
(item :tag "skip" nil)
(face :value default)))))
-(defcustom gnus-article-decode-hook
- '(article-decode-charset article-decode-encoded-words)
+(defcustom gnus-article-decode-hook nil
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
:group 'gnus-article-mime
:type 'function)
+(defcustom gnus-mime-multipart-functions nil
+ "An alist of MIME types to functions to display them.")
+
+(defcustom gnus-article-date-lapsed-new-header nil
+ "Whether the X-Sent and Date headers can coexist.
+When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
+either replace the old \"Date:\" header (if this variable is nil), or
+be added below it (otherwise)."
+ :group 'gnus-article-headers
+ :type 'boolean)
+
;;;
;;; The treatment variables
;;;
(integer :tag "Less")
(sexp :tag "Predicate")))
+(defvar gnus-article-treat-head-custom
+ '(choice (const :tag "Off" nil)
+ (const :tag "Header" head)))
+
(defvar gnus-article-treat-types '("text/plain")
"Parts to treat.")
"Whether to inhibit treatment.")
(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
- "Highlight the signature."
+ "Highlight the signature.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-highlight-signature 'highlight t)
(defcustom gnus-treat-buttonize t
- "Add buttons."
+ "Add buttons.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-buttonize 'highlight t)
(defcustom gnus-treat-buttonize-head 'head
- "Add buttons to the head."
+ "Add buttons to the head.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-buttonize-head 'highlight t)
(defcustom gnus-treat-emphasize t
- "Emphasize text."
+ "Emphasize text.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-emphasize 'highlight t)
(defcustom gnus-treat-strip-cr nil
- "Remove carriage returns."
+ "Remove carriage returns.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-headers 'head
- "Hide headers."
+ "Hide headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-boring-headers nil
- "Hide boring headers."
+ "Hide boring headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-signature nil
- "Hide the signature."
+ "Hide the signature.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-article nil
- "Fill the article."
+ "Fill the article.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation nil
- "Hide cited text."
+ "Hide cited text.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-pgp t
- "Strip PGP signatures."
+ "Strip PGP signatures.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-pem nil
- "Strip PEM signatures."
+ "Strip PEM signatures.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-banner t
"Strip banners from articles.
-The banner to be stripped is specified in the `banner' group parameter."
+The banner to be stripped is specified in the `banner' group parameter.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-highlight-headers 'head
- "Highlight the headers."
+ "Highlight the headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-highlight-headers 'highlight t)
(defcustom gnus-treat-highlight-citation t
- "Highlight cited text."
+ "Highlight cited text.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-highlight-citation 'highlight t)
(defcustom gnus-treat-date-ut nil
- "Display the Date in UT (GMT)."
+ "Display the Date in UT (GMT).
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-local nil
- "Display the Date in the local timezone."
+ "Display the Date in the local timezone.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-lapsed nil
- "Display the Date header in a way that says how much time has elapsed."
+ "Display the Date header in a way that says how much time has elapsed.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-original nil
- "Display the date in the original timezone."
+ "Display the date in the original timezone.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-iso8601 nil
- "Display the date in the ISO8601 format."
+ "Display the date in the ISO8601 format.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-user-defined nil
"Display the date in a user-defined format.
-The format is defined by the `gnus-article-time-format' variable."
+The format is defined by the `gnus-article-time-format' variable.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+
+(defcustom gnus-treat-strip-headers-in-body t
+ "Strip the X-No-Archive header line from the beginning of the body.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-trailing-blank-lines nil
- "Strip trailing blank lines."
+ "Strip trailing blank lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-leading-blank-lines nil
- "Strip leading blank lines."
+ "Strip leading blank lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-multiple-blank-lines nil
- "Strip multiple blank lines."
+ "Strip multiple blank lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-blank-lines nil
- "Strip all blank lines."
+ "Strip all blank lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-overstrike t
- "Treat overstrike highlighting."
+ "Treat overstrike highlighting.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-overstrike 'highlight t)
(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface))
'head nil)
- "Display X-Face headers."
+ "Display X-Face headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-display-xface 'highlight t)
(defcustom gnus-treat-display-smileys (if (and gnus-xemacs
(featurep 'xpm))
t nil)
- "Display smileys."
+ "Display smileys.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(put 'gnus-treat-display-smileys 'highlight t)
(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil)
- "Display picons."
+ "Display picons.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-display-picons 'highlight t)
(defcustom gnus-treat-capitalize-sentences nil
- "Capitalize sentence-starting words."
+ "Capitalize sentence-starting words.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-long-lines nil
- "Fill long lines."
+ "Fill long lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defcustom gnus-treat-play-sounds nil
- "Fill long lines."
+ "Play sounds.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
:type gnus-article-treat-custom)
(defvar gnus-article-mime-handle-alist-1 nil)
(defvar gnus-treatment-function-alist
'((gnus-treat-strip-banner gnus-article-strip-banner)
+ (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
- (gnus-treat-hide-headers gnus-article-hide-headers)
+ (gnus-treat-emphasize gnus-article-emphasize)
+ (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
(gnus-treat-hide-signature gnus-article-hide-signature)
(gnus-treat-hide-citation gnus-article-hide-citation)
(gnus-treat-highlight-headers gnus-article-highlight-headers)
(gnus-treat-highlight-citation gnus-article-highlight-citation)
(gnus-treat-highlight-signature gnus-article-highlight-signature)
- (gnus-treat-emphasize gnus-article-emphasize)
(gnus-treat-date-ut gnus-article-date-ut)
(gnus-treat-date-local gnus-article-date-local)
(gnus-treat-date-lapsed gnus-article-date-lapsed)
(put-text-property
(max (1- b) (point-min))
b 'intangible (cddr (memq 'intangible props)))))
-
-(defmacro gnus-with-article (article &rest forms)
- "Select ARTICLE and perform FORMS in the original article buffer.
-Then replace the article with the result."
- `(progn
- ;; We don't want the article to be marked as read.
- (let (gnus-mark-article-hook)
- (gnus-summary-select-article t t nil ,article))
- (set-buffer gnus-original-article-buffer)
- ,@forms
- (if (not (gnus-check-backend-function
- 'request-replace-article (car gnus-article-current)))
- (gnus-message 5 "Read-only group; not replacing")
- (unless (gnus-request-replace-article
- ,article (car gnus-article-current)
- (current-buffer) t)
- (error "Couldn't replace article")))
- ;; The cache and backlog have to be flushed somewhat.
- (when gnus-keep-backlog
- (gnus-backlog-remove-article
- (car gnus-article-current) (cdr gnus-article-current)))
- (when gnus-use-cache
- (gnus-cache-update-article
- (car gnus-article-current) (cdr gnus-article-current)))))
-
-(put 'gnus-with-article 'lisp-indent-function 1)
-(put 'gnus-with-article 'edebug-form-spec '(form body))
-
(defsubst gnus-article-unhide-text (b e)
"Remove hidden text properties from region between B and E."
(remove-text-properties b e gnus-hidden-properties)
i))
(defun article-hide-headers (&optional arg delete)
- "Toggle whether to hide unwanted headers and possibly sort them as well.
-If given a negative prefix, always show; if given a positive prefix,
-always hide."
- (interactive (gnus-article-hidden-arg))
- (current-buffer)
- (if (gnus-article-check-hidden-text 'headers arg)
- ;; Show boring headers as well.
- (gnus-article-show-hidden-text 'boring-headers)
- ;; This function might be inhibited.
- (unless gnus-inhibit-hiding
- (save-excursion
- (save-restriction
- (let ((buffer-read-only nil)
- (case-fold-search t)
- (props (nconc (list 'article-type 'headers)
- gnus-hidden-properties))
- (max (1+ (length gnus-sorted-header-list)))
- (ignored (when (not gnus-visible-headers)
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- beg)
- ;; First we narrow to just the headers.
- (widen)
- (goto-char (point-min))
- ;; Hide any "From " lines at the beginning of (mail) articles.
- (while (looking-at "From ")
- (forward-line 1))
- (unless (bobp)
- (if delete
- (delete-region (point-min) (point))
- (gnus-article-hide-text (point-min) (point) props)))
- ;; Then treat the rest of the header lines.
- (narrow-to-region
- (point)
- (if (search-forward "\n\n" nil t) ; if there's a body
- (progn (forward-line -1) (point))
- (point-max)))
- ;; Then we use the two regular expressions
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to
- ;; select which header lines is to remain visible in the
- ;; article buffer.
- (goto-char (point-min))
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- ;; Mark the rank of the header.
- (put-text-property
- (point) (1+ (point)) 'message-rank
- (if (or (and visible (looking-at visible))
- (and ignored
- (not (looking-at ignored))))
- (gnus-article-header-rank)
- (+ 2 max)))
- (forward-line 1))
- (message-sort-headers-1)
- (when (setq beg (text-property-any
- (point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We make the unwanted headers invisible.
- (if delete
- (delete-region beg (point-max))
- ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
- (gnus-article-hide-text-type beg (point-max) 'headers))
- ;; Work around XEmacs lossage.
- (put-text-property (point-min) beg 'invisible nil))))))))
+ "Hide unwanted headers and possibly sort them as well."
+ (interactive)
+ ;; This function might be inhibited.
+ (unless gnus-inhibit-hiding
+ (save-excursion
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (case-fold-search t)
+ (max (1+ (length gnus-sorted-header-list)))
+ (ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity gnus-ignored-headers
+ "\\|")))))
+ (visible
+ (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity gnus-visible-headers "\\|"))))
+ (inhibit-point-motion-hooks t)
+ beg)
+ ;; First we narrow to just the headers.
+ (article-narrow-to-head)
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (unless (bobp)
+ (delete-region (point-min) (point)))
+ ;; Then treat the rest of the header lines.
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (while (re-search-forward "^[^ \t]*:" nil t)
+ (beginning-of-line)
+ ;; Mark the rank of the header.
+ (put-text-property
+ (point) (1+ (point)) 'message-rank
+ (if (or (and visible (looking-at visible))
+ (and ignored
+ (not (looking-at ignored))))
+ (gnus-article-header-rank)
+ (+ 2 max)))
+ (forward-line 1))
+ (message-sort-headers-1)
+ (when (setq beg (text-property-any
+ (point-min) (point-max) 'message-rank (+ 2 max)))
+ ;; We delete the unwanted headers.
+ (add-text-properties (point-min) (+ 5 (point-min))
+ '(article-type headers dummy-invisible t))
+ (delete-region beg (point-max))))))))
(defun article-hide-boring-headers (&optional arg)
"Toggle hiding of headers that aren't very interesting.
(list gnus-boring-article-headers)
(inhibit-point-motion-hooks t)
elem)
- (nnheader-narrow-to-headers)
+ (article-narrow-to-head)
(while list
(setq elem (pop list))
(goto-char (point-min))
(cond
;; Hide empty headers.
((eq elem 'empty)
- (while (re-search-forward "^[^:]+:[ \t]*\n[^ \t]" nil t)
+ (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
(forward-line -1)
(gnus-article-hide-text-type
(progn (beginning-of-line) (point))
from reply-to
(ignore-errors
(equal
- (nth 1 (mail-extract-address-components from))
- (nth 1 (mail-extract-address-components reply-to)))))
+ (nth 1 (funcall gnus-extract-address-components from))
+ (nth 1 (funcall gnus-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
((eq elem 'date)
(let ((date (message-fetch-field "date")))
column)
(save-excursion
(save-restriction
- (message-narrow-to-head)
+ (article-narrow-to-head)
(while (not (eobp))
(cond
((< (setq column (- (gnus-point-at-eol) (point)))
(let ((buffer-read-only nil)
(width (window-width (get-buffer-window (current-buffer)))))
(save-restriction
- (widen)
(article-goto-body)
(let ((adaptive-fill-mode nil))
(while (not (eobp))
(forward-sentence)))))
(defun article-remove-cr ()
- "Translate CRLF pairs into LF, and then CR into LF.."
+ "Remove trailing CRs and then translate remaining CRs into LFs."
(interactive)
(save-excursion
(let ((buffer-read-only nil))
(goto-char (point-min))
- (while (search-forward "\r$" nil t)
+ (while (re-search-forward "\r+$" nil t)
(replace-match "" t t))
(goto-char (point-min))
(while (search-forward "\r" nil t)
(case-fold-search t)
from last)
(save-restriction
- (message-narrow-to-head)
+ (article-narrow-to-head)
(goto-char (point-min))
(setq from (message-fetch-field "from"))
(goto-char (point-min))
(interactive "P")
(save-excursion
(save-restriction
- (message-narrow-to-head)
+ (article-narrow-to-head)
(let* ((inhibit-point-motion-hooks t)
(case-fold-search t)
(ct (message-fetch-field "Content-Type" t))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
- (let ((inhibit-point-motion-hooks t)
- (mail-parse-charset gnus-newsgroup-charset)
- buffer-read-only)
- (save-restriction
- (message-narrow-to-head)
- (funcall gnus-decode-header-function (point-min) (point-max)))))
+ (let (buffer-read-only)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (mime-decode-header-in-buffer charset)
+ )))
(defun article-de-quoted-unreadable (&optional force)
"Translate a quoted-printable-encoded article.
"Remove any PGP headers and signatures in the current article."
(interactive)
(save-excursion
- (let ((inhibit-point-motion-hooks t)
- buffer-read-only beg end)
- (widen)
- (goto-char (point-min))
- ;; Hide the "header".
- (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (push 'pgp gnus-article-wash-types)
- (delete-region (1+ (match-beginning 0)) (match-end 0))
- ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
- (when (looking-at "Hash:.*$")
- (delete-region (point) (1+ (gnus-point-at-eol))))
- (setq beg (point))
- ;; Hide the actual signature.
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
- (setq end (1+ (match-beginning 0)))
- (delete-region
- end
- (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
- (match-end 0)
- ;; Perhaps we shouldn't hide to the end of the buffer
- ;; if there is no end to the signature?
- (point-max))))
- ;; Hide "- " PGP quotation markers.
- (when (and beg end)
- (narrow-to-region beg end)
- (goto-char (point-min))
- (while (re-search-forward "^- " nil t)
- (delete-region
- (match-beginning 0) (match-end 0)))
- (widen))
- (gnus-run-hooks 'gnus-article-hide-pgp-hook)))))
+ (save-restriction
+ (let ((inhibit-point-motion-hooks t)
+ buffer-read-only beg end)
+ (article-goto-body)
+ ;; Hide the "header".
+ (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
+ (push 'pgp gnus-article-wash-types)
+ (delete-region (match-beginning 0) (match-end 0))
+ ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
+ (when (looking-at "Hash:.*$")
+ (delete-region (point) (1+ (gnus-point-at-eol))))
+ (setq beg (point))
+ ;; Hide the actual signature.
+ (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
+ (setq end (1+ (match-beginning 0)))
+ (delete-region
+ end
+ (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
+ (match-end 0)
+ ;; Perhaps we shouldn't hide to the end of the buffer
+ ;; if there is no end to the signature?
+ (point-max))))
+ ;; Hide "- " PGP quotation markers.
+ (when (and beg end)
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (while (re-search-forward "^- " nil t)
+ (delete-region
+ (match-beginning 0) (match-end 0)))
+ (widen))
+ (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
(defun article-hide-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
(unless (gnus-article-check-hidden-text 'pem arg)
(save-excursion
(let (buffer-read-only end)
- (widen)
(goto-char (point-min))
;; Hide the horrendously ugly "header".
(when (and (search-forward
(interactive)
(save-excursion
(save-restriction
- (let ((inhibit-point-motion-hooks t)
- (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
- (gnus-signature-limit nil)
- buffer-read-only beg end)
- (when banner
- (article-goto-body)
- (cond
- ((eq banner 'signature)
- (when (gnus-article-narrow-to-signature)
- (widen)
- (forward-line -1)
- (delete-region (point) (point-max))))
- ((stringp banner)
- (while (re-search-forward banner nil t)
- (delete-region (match-beginning 0) (match-end 0))))))))))
+ (let ((inhibit-point-motion-hooks t)
+ (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
+ (gnus-signature-limit nil)
+ buffer-read-only beg end)
+ (when banner
+ (article-goto-body)
+ (cond
+ ((eq banner 'signature)
+ (when (gnus-article-narrow-to-signature)
+ (widen)
+ (forward-line -1)
+ (delete-region (point) (point-max))))
+ ((stringp banner)
+ (while (re-search-forward banner nil t)
+ (delete-region (match-beginning 0) (match-end 0))))))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
(gnus-article-hide-text-type
(point-min) (point-max) 'signature)))))))
+(defun article-strip-headers-in-body ()
+ "Strip offensive headers from bodies."
+ (interactive)
+ (save-excursion
+ (article-goto-body)
+ (let ((case-fold-search t))
+ (when (looking-at "x-no-archive:")
+ (gnus-delete-line)))))
+
(defun article-strip-leading-blank-lines ()
"Remove all blank lines from the beginning of the article."
(interactive)
(looking-at "[ \t]*$"))
(gnus-delete-line))))))
+(defun article-narrow-to-head ()
+ "Narrow the buffer to the head of the message.
+Point is left at the beginning of the narrowed-to region."
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil 1)
+ (1- (point))
+ (point-max)))
+ (goto-char (point-min)))
+
(defun article-goto-body ()
"Place point at the start of the body."
(goto-char (point-min))
(defun gnus-article-narrow-to-signature ()
"Narrow to the signature; return t if a signature is found, else nil."
- (widen)
(let ((inhibit-point-motion-hooks t))
(when (gnus-article-search-signature)
(forward-line 1)
(goto-char cur)
nil)))
-(eval-and-compile
- (autoload 'w3-display "w3-parse")
- (autoload 'w3-do-setup "w3" "" t)
- (autoload 'w3-region "w3-display" "" t))
-
-(defun gnus-article-treat-html ()
- "Render HTML."
- (interactive)
- (let ((cbuf (current-buffer)))
- (set-buffer gnus-article-buffer)
- (let (buf buffer-read-only b e)
- (w3-do-setup)
- (goto-char (point-min))
- (narrow-to-region
- (if (search-forward "\n\n" nil t)
- (setq b (point))
- (point-max))
- (setq e (point-max)))
- (with-temp-buffer
- (insert-buffer-substring gnus-article-buffer b e)
- (require 'url)
- (save-window-excursion
- (w3-region (point-min) (point-max))
- (setq buf (buffer-substring-no-properties (point-min) (point-max)))))
- (when buf
- (delete-region (point-min) (point-max))
- (insert buf))
- (widen)
- (goto-char (point-min))
- (set-window-start (get-buffer-window (current-buffer)) (point-min))
- (set-buffer cbuf))))
-
(defun gnus-article-hidden-arg ()
"Return the current prefix arg as a number, or 0 if no prefix."
(list (if current-prefix-arg
means show, 0 means toggle."
(save-excursion
(save-restriction
- (widen)
(let ((hide (gnus-article-hidden-text-p type)))
(cond
((or (null arg)
"Say whether the current buffer contains hidden text of type TYPE."
(let ((pos (text-property-any (point-min) (point-max) 'article-type type)))
(while (and pos
- (not (get-text-property pos 'invisible)))
+ (not (get-text-property pos 'invisible))
+ (not (get-text-property pos 'dummy-invisible)))
(setq pos
(text-property-any (1+ pos) (point-max) 'article-type type)))
(if pos
(defun article-date-ut (&optional type highlight header)
"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."
+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
(mail-header-date (save-excursion
gnus-current-headers))
(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))
- (date-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
(inhibit-point-motion-hooks t)
- bface eface newline)
+ (newline t)
+ bface eface)
(when (and date (not (string= date "")))
(save-excursion
(save-restriction
- (nnheader-narrow-to-headers)
+ (article-narrow-to-head)
+ (when (re-search-forward tdate-regexp nil t)
+ (setq bface (get-text-property (gnus-point-at-bol) 'face)
+ eface (get-text-property (1- (gnus-point-at-eol))
+ 'face))
+ (forward-line 1))
+ (goto-char (point-min))
(let ((buffer-read-only nil))
- ;; Delete any old Date headers.
- (if (re-search-forward date-regexp nil t)
- (progn
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol))
- 'face))
+ ;; Delete any old Date headers.
+ (while (re-search-forward date-regexp nil t)
+ (if newline
(delete-region (progn (beginning-of-line) (point))
(progn (end-of-line) (point)))
- (beginning-of-line))
- (goto-char (point-max))
- (setq newline t))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (setq newline nil))
(insert (article-make-date-line date type))
+ (when newline
+ (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))
- (when newline
- (end-of-line)
- (insert "\n"))))))))
+ 'face eface))))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
article-remove-cr
article-display-x-face
article-de-quoted-unreadable
- article-mime-decode-quoted-printable
article-hide-pgp
article-strip-banner
article-hide-pem
article-hide-signature
+ article-strip-headers-in-body
article-remove-trailing-blank-lines
article-strip-leading-blank-lines
article-strip-multiple-blank-lines
(put 'gnus-article-mode 'mode-class 'special)
-(set-keymap-parent gnus-article-mode-map widget-keymap)
-
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
+ gnus-mouse-2 gnus-article-push-button
+ "\r" gnus-article-press-button
+ "\t" gnus-article-next-button
+ "\M-\t" gnus-article-prev-button
"e" gnus-article-edit
"<" beginning-of-buffer
">" end-of-buffer
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
-(substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+;; Define almost undefined keys to `gnus-article-read-summary-keys'.
+(mapcar
+ (lambda (key)
+ (unless (lookup-key gnus-article-mode-map key)
+ (define-key gnus-article-mode-map key
+ 'gnus-article-read-summary-keys)))
+ (delq nil
+ (append
+ (mapcar
+ (lambda (elt)
+ (let ((key (car elt)))
+ (and (> (length key) 0)
+ (not (eq 'menu-bar (aref key 0)))
+ (symbolp (lookup-key gnus-summary-mode-map key))
+ key)))
+ (accessible-keymaps gnus-summary-mode-map))
+ (let ((c 127)
+ keys)
+ (while (>= c 32)
+ (push (char-to-string c) keys)
+ (decf c))
+ keys))))
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
["Hide signature" gnus-article-hide-signature t]
["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 carriage return" gnus-article-remove-cr t]))
;; Note "Commands" menu is defined in gnus-sum.el for consistency
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(make-local-variable 'minor-mode-alist)
+ (unless (assq 'gnus-show-mime minor-mode-alist)
+ (push (list 'gnus-show-mime " MIME") minor-mode-alist))
(use-local-map gnus-article-mode-map)
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
(buffer-disable-undo)
(setq buffer-read-only t)
(set-syntax-table gnus-article-mode-syntax-table)
- (mm-enable-multibyte)
(gnus-run-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (mm-enable-multibyte)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(forward-line line)
(point)))))
+;;; @@ article filters
+;;;
+
+(defun gnus-article-display-mime-message ()
+ "Article display method for MIME message."
+ ;; called from `gnus-original-article-buffer'.
+ (let (charset all-headers)
+ (with-current-buffer gnus-summary-buffer
+ (setq charset default-mime-charset
+ all-headers gnus-have-all-headers))
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ (with-current-buffer (get-buffer-create gnus-article-buffer)
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset))
+ (mime-display-message mime-message-structure
+ gnus-article-buffer nil gnus-article-mode-map)
+ (when all-headers
+ (gnus-article-hide-headers nil -1))
+ )
+ ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
+ (make-local-variable 'mime-button-mother-dispatcher)
+ (setq mime-button-mother-dispatcher
+ (function gnus-article-push-button))
+ (run-hooks 'gnus-mime-article-prepare-hook))
+
+(defun gnus-article-display-traditional-message ()
+ "Article display method for traditional message."
+ (set-buffer gnus-article-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)))
+
+(defun gnus-article-make-full-mail-header (&optional number charset)
+ "Create a new mail header structure in a raw article buffer."
+ (unless (and number charset)
+ (save-current-buffer
+ (set-buffer gnus-summary-buffer)
+ (unless number
+ (setq number (or (cdr gnus-article-current) 0)))
+ (unless charset
+ (setq charset (or default-mime-charset 'x-ctext)))))
+ (goto-char (point-min))
+ (let ((header-end (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (goto-char (point-max))))
+ (chars (- (point-max) (point)))
+ (lines (count-lines (point) (point-max)))
+ (default-mime-charset charset)
+ xref)
+ (narrow-to-region (point-min) header-end)
+ (setq xref (std11-fetch-field "xref"))
+ (prog1
+ (make-full-mail-header
+ number
+ (std11-fetch-field "subject")
+ (std11-fetch-field "from")
+ (std11-fetch-field "date")
+ (std11-fetch-field "message-id")
+ (std11-fetch-field "references")
+ chars
+ lines
+ (when xref (concat "Xref: " xref)))
+ (widen))))
+
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
ARTICLE should either be an article number or a Message-ID.
result)
(save-excursion
(gnus-article-setup-buffer)
- (set-buffer gnus-article-buffer)
+ (set-buffer gnus-original-article-buffer)
;; Deactivate active regions.
(when (and (boundp 'transient-mark-mode)
transient-mark-mode)
(when (gnus-visual-p 'article-highlight 'highlight)
(gnus-run-hooks 'gnus-visual-mark-article-hook))
;; Set the global newsgroup variables here.
- ;; Suggested by Jim Sisolak
- ;; <sisolak@trans4.neep.wisc.edu>.
(gnus-set-global-variables)
(setq gnus-have-all-headers
(or all-headers gnus-show-all-headers))))
;;;###autoload
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
- ;; Hooks for getting information from the article.
- ;; This hook must be called before being narrowed.
- (let ((gnus-article-buffer (current-buffer))
- buffer-read-only)
- (unless (eq major-mode 'gnus-article-mode)
- (gnus-article-mode))
- (setq buffer-read-only nil)
+ (let ((method
+ (if gnus-show-mime
+ (progn
+ (setq mime-message-structure gnus-current-headers)
+ gnus-article-display-method-for-mime)
+ gnus-article-display-method-for-traditional)))
(gnus-run-hooks 'gnus-tmp-internal-hook)
(gnus-run-hooks 'gnus-article-prepare-hook)
- (when gnus-display-mime-function
- (funcall gnus-display-mime-function))))
+ ;; Display message.
+ (funcall method)
+ ;; Associate this article with the current summary buffer.
+ (setq gnus-article-current-summary gnus-summary-buffer)
+ ;; Perform the article display hooks.
+ (gnus-run-hooks 'gnus-article-display-hook)))
;;;
;;; Gnus MIME viewing functions
(setq buffer-file-name nil))
(goto-char (point-min))))
-(defun gnus-mime-inline-part (&optional charset)
+(defun gnus-mime-inline-part (&optional handle)
"Insert the MIME part under point into the current buffer."
- (interactive "P") ; For compatibility reasons we are not using "z".
+ (interactive)
(gnus-article-check-buffer)
- (let* ((data (get-text-property (point) 'gnus-data))
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
contents
(b (point))
buffer-read-only)
- (if (mm-handle-undisplayer data)
- (mm-remove-part data)
- (setq contents (mm-get-part data))
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (setq contents (mm-get-part handle))
(forward-line 2)
- (when charset
- (unless (symbolp charset)
- (setq charset (mm-read-coding-system "Charset: ")))
- (setq contents (mm-decode-coding-string contents charset)))
- (mm-insert-inline data contents)
+ (mm-insert-inline handle contents)
(goto-char b))))
(defun gnus-mime-externalize-part (&optional handle)
(save-restriction
(narrow-to-region (point) (1+ (point)))
(mm-display-part handle)
+ ;; We narrow to the part itself and
+ ;; then call the treatment functions.
+ (goto-char (point-min))
+ (forward-line 1)
+ (narrow-to-region (point) (point-max))
(gnus-treat-article
nil id
(1- (length gnus-article-mime-handles))
(goto-char (widget-get elems :from))
(gnus-article-press-button))
+(defvar gnus-displaying-mime nil)
+
(defun gnus-display-mime (&optional ihandles)
"Display the MIME parts."
(save-excursion
(set-window-point window point)))
(let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
buffer-read-only handle name type b e display)
- (unless ihandles
+ (when (and (not ihandles)
+ (not gnus-displaying-mime))
;; Top-level call; we clean up.
(mm-destroy-parts gnus-article-mime-handles)
(setq gnus-article-mime-handles handles
(or (not (stringp (car handles)))
(cdr handles)))
(progn
- (unless ihandles
+ (when (and (not ihandles)
+ (not gnus-displaying-mime))
;; Clean up for mime parts.
(article-goto-body)
(delete-region (point) (point-max)))
- (gnus-mime-display-part handles))
+ (let ((gnus-displaying-mime t))
+ (gnus-mime-display-part handles)))
(save-restriction
(article-goto-body)
(narrow-to-region (point) (point-max))
- (gnus-treat-article nil 1 1)))
+ (gnus-treat-article nil 1 1)
+ (widen)))
;; Highlight the headers.
(save-excursion
(save-restriction
;; Single part.
((not (stringp (car handle)))
(gnus-mime-display-single handle))
+ ;; User-defined multipart
+ ((cdr (assoc (car handle) gnus-mime-multipart-functions))
+ (funcall (cdr (assoc (car handle) gnus-mime-multipart-functions))
+ handle))
;; multipart/alternative
((and (equal (car handle) "multipart/alternative")
(not gnus-mime-display-multipart-as-mixed))
"Return a string which display status of article washing."
(save-excursion
(set-buffer gnus-article-buffer)
- (let ((cite (memq 'cite gnus-article-wash-types))
- (headers (memq 'headers gnus-article-wash-types))
- (boring (memq 'boring-headers gnus-article-wash-types))
- (pgp (memq 'pgp gnus-article-wash-types))
- (pem (memq 'pem gnus-article-wash-types))
- (signature (memq 'signature gnus-article-wash-types))
- (overstrike (memq 'overstrike gnus-article-wash-types))
- (emphasis (memq 'emphasis gnus-article-wash-types)))
- (format "%c%c%c%c%c%c"
+ (let ((cite (gnus-article-hidden-text-p 'cite))
+ (headers (gnus-article-hidden-text-p 'headers))
+ (boring (gnus-article-hidden-text-p 'boring-headers))
+ (pgp (gnus-article-hidden-text-p 'pgp))
+ (pem (gnus-article-hidden-text-p 'pem))
+ (signature (gnus-article-hidden-text-p 'signature))
+ (overstrike (gnus-article-hidden-text-p 'overstrike))
+ (emphasis (gnus-article-hidden-text-p 'emphasis))
+ (mime gnus-show-mime))
+ (format "%c%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
(if (or pgp pem) ?p ? )
(if signature ?s ? )
(if overstrike ?o ? )
+ (if mime ?m ? )
(if emphasis ?e ? )))))
(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
- (unless (equal major-mode 'gnus-article-mode)
+ (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
(error "Command invoked outside of a Gnus article buffer")))
(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
(assq article gnus-newsgroup-reads)))
gnus-canceled-mark))
nil)
- ;; We first check `gnus-original-article-buffer'.
- ((and (get-buffer gnus-original-article-buffer)
- (numberp article)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (and (equal (car gnus-original-article) group)
- (eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
- 'article)
;; Check the backlog.
((and gnus-keep-backlog
(gnus-backlog-request-article group article (current-buffer)))
:group 'gnus-article-various
:type 'hook)
+(defcustom gnus-article-edit-article-setup-function
+ 'gnus-article-mime-edit-article-setup
+ "Function called to setup an editing article buffer."
+ :group 'gnus-article-various
+ :type 'function)
+
(defvar gnus-article-edit-done-function nil)
(defvar gnus-article-edit-mode-map nil)
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
+ (when gnus-article-edit-article-setup-function
+ (funcall gnus-article-edit-article-setup-function))
(gnus-message 6 "C-c C-c to end edits")))
(defun gnus-article-edit-done (&optional arg)
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start)))
+ (remove-hook 'gnus-article-mode-hook
+ 'gnus-article-mime-edit-article-unwind)
(gnus-article-edit-exit)
(save-excursion
(set-buffer buf)
(query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
;;;
+;;; Article editing with MIME-Edit
+;;;
+
+(defcustom gnus-article-mime-edit-article-setup-hook nil
+ "Hook run after setting up a MIME editing article buffer."
+ :group 'gnus-article-various
+ :type 'hook)
+
+(defun gnus-article-mime-edit-article-unwind ()
+ "Unwind `gnus-article-buffer' if article editing was given up."
+ (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (when mime-edit-mode-flag
+ (mime-edit-exit 'nomime 'no-error)
+ (message ""))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0)))
+
+(defun gnus-article-mime-edit-article-setup ()
+ "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
+after replacing with the original article."
+ (setq gnus-show-mime t)
+ (setq gnus-article-edit-done-function
+ `(lambda (&rest args)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator))
+ nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ (apply ,gnus-article-edit-done-function args)
+ (set-buffer gnus-original-article-buffer)
+ (erase-buffer)
+ (insert-buffer gnus-article-buffer)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)))
+ (substitute-key-definition
+ 'gnus-article-edit-exit 'gnus-article-mime-edit-exit
+ gnus-article-edit-mode-map)
+ (erase-buffer)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-edit-again)
+ (when (featurep 'font-lock)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
+ (font-lock-set-defaults)
+ (turn-on-font-lock))
+ (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
+ (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook))
+
+(defun gnus-article-mime-edit-exit ()
+ "Exit the article MIME editing without updating."
+ (interactive)
+ (let ((winconf gnus-prev-winconf)
+ buf)
+ (when mime-edit-mode-flag
+ (mime-edit-exit)
+ (message ""))
+ (goto-char (point-min))
+ (let (case-fold-search)
+ (when (re-search-forward
+ (format "^%s$" (regexp-quote mail-header-separator)) nil t)
+ (replace-match "")))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode 0))
+ ;; We remove all text props from the article buffer.
+ (setq buf (format "%s" (buffer-string)))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)
+ (insert buf)
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (gnus-article-prepare-display)
+ (set-window-configuration winconf)))
+
+;;;
;;; Article highlights
;;;
(when fun
(funcall fun data))))
+(defun gnus-article-prev-button (n)
+ "Move point to N buttons backward.
+If N is negative, move forward instead."
+ (interactive "p")
+ (gnus-article-next-button (- n)))
+
+(defun gnus-article-next-button (n)
+ "Move point to N buttons forward.
+If N is negative, move backward instead."
+ (interactive "p")
+ (let ((function (if (< n 0) 'previous-single-property-change
+ 'next-single-property-change))
+ (inhibit-point-motion-hooks t)
+ (backward (< n 0))
+ (limit (if (< n 0) (point-min) (point-max))))
+ (setq n (abs n))
+ (while (and (not (= limit (point)))
+ (> n 0))
+ ;; Skip past the current button.
+ (when (get-text-property (point) 'gnus-callback)
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Go to the next (or previous) button.
+ (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
+ ;; Put point at the start of the button.
+ (when (and backward (not (get-text-property (point) 'gnus-callback)))
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Skip past intangible buttons.
+ (when (get-text-property (point) 'intangible)
+ (incf n))
+ (decf n))
+ (unless (zerop n)
+ (gnus-message 5 "No more buttons"))
+ n))
+
(defun gnus-article-highlight (&optional force)
"Highlight current article.
This function calls `gnus-article-highlight-headers',
(case-fold-search t)
(inhibit-point-motion-hooks t)
entry regexp header-face field-face from hpoints fpoints)
- (message-narrow-to-head)
+ (article-narrow-to-head)
(while (setq entry (pop alist))
(goto-char (point-min))
(setq regexp (concat "^\\("
(interactive)
(save-excursion
(set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (case-fold-search t)
- (alist gnus-header-button-alist)
- entry beg end)
- (nnheader-narrow-to-headers)
- (while alist
- ;; Each alist entry.
- (setq entry (car alist)
- alist (cdr alist))
- (goto-char (point-min))
- (while (re-search-forward (car entry) nil t)
- ;; Each header matching the entry.
- (setq beg (match-beginning 0))
- (setq end (or (and (re-search-forward "^[^ \t]" nil t)
- (match-beginning 0))
- (point-max)))
- (goto-char beg)
- (while (re-search-forward (nth 1 entry) end t)
- ;; Each match within a header.
- (let* ((entry (cdr entry))
- (start (match-beginning (nth 1 entry)))
- (end (match-end (nth 1 entry)))
- (form (nth 2 entry)))
- (goto-char (match-end 0))
- (when (eval form)
- (gnus-article-add-button
- start end (nth 3 entry)
- (buffer-substring (match-beginning (nth 4 entry))
- (match-end (nth 4 entry)))))))
- (goto-char end))))
- (widen)))
+ (save-restriction
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t)
+ (alist gnus-header-button-alist)
+ entry beg end)
+ (article-narrow-to-head)
+ (while alist
+ ;; Each alist entry.
+ (setq entry (car alist)
+ alist (cdr alist))
+ (goto-char (point-min))
+ (while (re-search-forward (car entry) nil t)
+ ;; Each header matching the entry.
+ (setq beg (match-beginning 0))
+ (setq end (or (and (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char beg)
+ (while (re-search-forward (nth 1 entry) end t)
+ ;; Each match within a header.
+ (let* ((entry (cdr entry))
+ (start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (form (nth 2 entry)))
+ (goto-char (match-end 0))
+ (when (eval form)
+ (gnus-article-add-button
+ start end (nth 3 entry)
+ (buffer-substring (match-beginning (nth 4 entry))
+ (match-end (nth 4 entry)))))))
+ (goto-char end)))))))
;;; External functions:
(nconc (and gnus-article-mouse-face
(list gnus-mouse-face-prop gnus-article-mouse-face))
(list 'gnus-callback fun)
- (and data (list 'gnus-data data))))
- (widget-convert-button 'link from to :action 'gnus-widget-press-button
- :button-keymap gnus-widget-button-keymap))
+ (and data (list 'gnus-data data)))))
;;; Internal functions:
(setq to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
subject (cdr-safe (assoc "subject" args)))
- (message-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (mapconcat 'identity (cdar args) ", "))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject))))
+ (gnus-setup-message 'reply
+ (message-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (mapconcat 'identity (cdar args) ", "))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject)))))
(defun gnus-button-mailto (address)
;; Mail to ADDRESS.
(set-buffer (gnus-copy-article-buffer))
- (message-reply address))
+ (gnus-setup-message 'reply
+ (message-reply address)))
(defun gnus-button-reply (address)
;; Reply to ADDRESS.
- (message-reply address))
+ (gnus-setup-message 'reply
+ (message-reply address)))
(defun gnus-button-url (address)
"Browse ADDRESS."
(while list
(when (string-match (pop list) type)
(throw 'found t)))))))
+ (highlightp (gnus-visual-p 'article-highlight 'highlight))
val elem)
- (when (gnus-visual-p 'article-highlight 'highlight)
- (gnus-run-hooks 'gnus-part-display-hook)
- (while (setq elem (pop alist))
- (setq val (symbol-value (car elem)))
- (when (and (or (consp val)
- treated-type)
- (gnus-treat-predicate val))
+ (gnus-run-hooks 'gnus-part-display-hook)
+ (while (setq elem (pop alist))
+ (setq val (symbol-value (car elem)))
+ (when (and (or (consp val)
+ treated-type)
+ (gnus-treat-predicate val)
+ (or (not (get (car elem) 'highlight))
+ highlightp))
+ (save-restriction
(funcall (cadr elem)))))))
;; Dynamic variables.
(t
(error "%S is not a valid value" val))))
+
+;;; @ for mime-view
+;;;
+
+(defun gnus-article-header-presentation-method (entity situation)
+ (mime-insert-header entity)
+ )
+
+(set-alist 'mime-header-presentation-method-alist
+ 'gnus-original-article-mode
+ #'gnus-article-header-presentation-method)
+
+(defun gnus-mime-preview-quitting-method ()
+ (mime-preview-kill-buffer)
+ (delete-other-windows)
+ (gnus-article-show-summary)
+ (gnus-summary-select-article gnus-show-all-headers t))
+
+(set-alist 'mime-preview-quitting-method-alist
+ 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
+
+(defun gnus-following-method (buf)
+ (set-buffer buf)
+ (message-followup)
+ (message-yank-original)
+ (kill-buffer buf)
+ (goto-char (point-min))
+ )
+
+(set-alist 'mime-preview-following-method-alist
+ 'gnus-original-article-mode #'gnus-following-method)
+
+(set-alist 'mime-preview-over-to-previous-method-alist
+ 'gnus-original-article-mode
+ (lambda ()
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?P))))
+
+(set-alist 'mime-preview-over-to-next-method-alist
+ 'gnus-original-article-mode'
+ (lambda ()
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?N))))
+
+
+;;; @ end
+;;;
+
(gnus-ems-redefine)
(provide 'gnus-art)
projects / elisp / gnus.git- / blobdiff