X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=b46cf8bbd486d4ba9da53f5e4a46168214710c15;hb=87c0ec91a2083f02b65849fd7cbf893f1fcfb2f8;hp=d3b2357a318a7038f604295cd668b10ecdb2a2ee;hpb=517d8c1e72ed898204ef80597cda8084746d52c3;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index d3b2357..b46cf8b 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,10 @@ -;;; gnus-art.el --- article mode commands for Gnus +;;; gnus-art.el --- article mode commands for Semi-gnus ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; MORIOKA Tomohiko +;; Katsumi Yamaoka +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,6 +35,8 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(require 'alist) +(require 'mime-view) (defgroup gnus-article nil "Article display." @@ -119,7 +123,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" + "From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -272,6 +276,7 @@ be fed to `format-time-string'." :group 'gnus-article-washing) (eval-and-compile + (autoload 'hexl-hex-string-to-integer "hexl") (autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-extract-address-components "mail-extr")) @@ -375,18 +380,27 @@ be used as possible file names." (sexp :value nil)))) (defcustom gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header." + "*If nil, MIME-decode even if there is no MIME-Version header." :group 'gnus-article-mime :type 'boolean) -(defcustom gnus-show-mime-method 'metamail-buffer - "Function to process a MIME message. +(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-decode-encoded-word-method 'gnus-article-de-quoted-unreadable - "*Function to decode MIME encoded words. +(defcustom gnus-article-display-method-for-encoded-word + 'gnus-article-display-message-with-encoded-word + "*Function to display a message with MIME encoded-words. +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) @@ -762,8 +776,8 @@ always hide." 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"))) @@ -945,43 +959,14 @@ characters to translate to." (process-send-region "article-x-face" beg end) (process-send-eof "article-x-face")))))))))) -(defun gnus-article-decode-mime-words () - "Decode all MIME-encoded words in the article." - (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((inhibit-point-motion-hooks t) - buffer-read-only) - (rfc2047-decode-region (point-min) (point-max))))) - -(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) -(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) -(defun article-decode-rfc1522 () - "Remove QP encoding from headers." - (let ((inhibit-point-motion-hooks t) - (buffer-read-only nil)) - (save-restriction - (message-narrow-to-head) - (rfc2047-decode-region (point-min) (point-max))))) - -(defun article-de-quoted-unreadable (&optional force) - "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"))) - (gnus-article-decode-rfc1522) - (when (or force - (and type (string-match "quoted-printable" (downcase type)))) - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - (quoted-printable-decode-region (point) (point-max)))))) - -(defun article-mime-decode-quoted-printable-buffer () - "Decode Quoted-Printable in the current buffer." - (quoted-printable-decode-region (point-min) (point-max))) +(defun gnus-article-decode-rfc1522 () + "Decode MIME encoded-words in header fields." + (let (buffer-read-only) + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (eword-decode-header charset) + ))) (defun article-hide-pgp (&optional arg) "Toggle hiding of any PGP headers and signatures in the current article. @@ -1117,21 +1102,10 @@ always hide." (while (re-search-forward "^[ \t]*\n" nil t) (replace-match "" t t))))) -(defvar mime::preview/content-list) -(defvar mime::preview-content-info/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 (and (boundp 'mime::preview/content-list) - mime::preview/content-list) - ;; We have a MIMEish article, so we use the MIME data to narrow. - (let ((pcinfo (car (last mime::preview/content-list)))) - (ignore-errors - (narrow-to-region - (funcall (intern "mime::preview-content-info/point-min") pcinfo) - (point-max))))) - (when (gnus-article-search-signature) (forward-line 1) ;; Check whether we have some limits to what we consider @@ -1189,7 +1163,7 @@ Put point at the beginning of the signature separator." (setq b (point)) (point-max)) (setq e (point-max))) - (with-temp-buffer + (nnheader-temp-write nil (insert-buffer-substring gnus-article-buffer b e) (require 'url) (save-window-excursion @@ -1816,8 +1790,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (article-fill . gnus-article-word-wrap) article-remove-cr article-display-x-face - article-de-quoted-unreadable - article-mime-decode-quoted-printable article-hide-pgp article-hide-pem article-hide-signature @@ -1892,7 +1864,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["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])) + )) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -1936,8 +1908,6 @@ commands: (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte t)) (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () @@ -1992,6 +1962,76 @@ commands: (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 ((default-mime-charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (mime-display-message mime-message-structure + gnus-article-buffer nil gnus-article-mode-map)) + ;; `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-display-message-with-encoded-word () + "Article display method for message with encoded-words." + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (gnus-article-display-traditional-message) + (let (buffer-read-only) + (eword-decode-header charset) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (decode-mime-charset-region (match-end 0) (point-max) charset))) + (mime-maybe-hide-echo-buffer)) + (gnus-run-hooks 'gnus-mime-article-prepare-hook)) + +(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. @@ -2009,7 +2049,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." 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) @@ -2085,21 +2125,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (or all-headers gnus-show-all-headers)))) (when (or (numberp article) (stringp article)) - ;; Hooks for getting information from the article. - ;; This hook must be called before being narrowed. - (let (buffer-read-only) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (when gnus-show-mime - (if (or (not gnus-strict-mime) - (gnus-fetch-field "Mime-Version")) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (funcall gnus-show-mime-method)) - (funcall gnus-decode-encoded-word-method))) - ;; Perform the article display hooks. - (gnus-run-hooks 'gnus-article-display-hook)) + (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) (setq gnus-page-broken @@ -2113,6 +2139,26 @@ If ALL-HEADERS is non-nil, no headers are hidden." (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +(defun gnus-article-prepare-display () + "Make the current buffer look like a nice article." + (let ((method + (if gnus-show-mime + (progn + (mime-parse-buffer) + (if (or (not gnus-strict-mime) + (mime-fetch-field "MIME-Version")) + gnus-article-display-method-for-mime + gnus-article-display-method-for-encoded-word)) + gnus-article-display-method-for-traditional))) + (gnus-run-hooks 'gnus-tmp-internal-hook) + (gnus-run-hooks 'gnus-article-prepare-hook) + ;; 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))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -2149,7 +2195,7 @@ Provided for backwards compatibility." (defun gnus-output-to-file (file-name) "Append the current article to a file named FILE-NAME." (let ((artbuf (current-buffer))) - (with-temp-buffer + (nnheader-temp-write nil (insert-buffer-substring artbuf) ;; Append newline at end of the buffer as separator, and then ;; save it to file. @@ -2468,15 +2514,6 @@ If given a prefix, show the hidden text instead." (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))) @@ -2551,6 +2588,12 @@ If given a prefix, show the hidden text instead." :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) @@ -2608,6 +2651,8 @@ groups." (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) @@ -2638,6 +2683,8 @@ groups." (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) @@ -2689,6 +2736,86 @@ groups." (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))) + (define-key (current-local-map) "\C-c\C-k" 'gnus-article-mime-edit-exit) + (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 ;;; @@ -3095,7 +3222,7 @@ specified by `gnus-button-alist'." (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) - (setq pairs (split-string query "&")) + (setq pairs (gnus-split-string query "&")) (while pairs (setq cur (car pairs) pairs (cdr pairs)) @@ -3155,26 +3282,29 @@ forbidden in URL encoding." (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." @@ -3256,6 +3386,45 @@ forbidden in URL encoding." (gnus-article-prev-page) (select-window win))) + +;;; @ for mime-view +;;; + +(defun gnus-article-header-presentation-method (entity situation) + (mime-insert-decoded-header entity) + ) + +(set-alist 'mime-header-presentation-method-alist + 'gnus-original-article-mode + #'gnus-article-header-presentation-method) + +(defun gnus-mime-preview-quitting-method () + (if gnus-show-mime + (gnus-article-show-summary) + (mime-preview-kill-buffer) + (delete-other-windows) + (gnus-article-show-summary) + (gnus-summary-select-article nil 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) + + +;;; @ end +;;; + (gnus-ems-redefine) (provide 'gnus-art)