X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=668f7b9e275d2673beccccdac5eccfefab0412a4;hb=b14ba71ca00ad909b738bad1898f1908c0e6d2eb;hp=3a1d1fdd2fa893c727b5959ea10dcfd7c1239bd1;hpb=80249bc90ebe20d49eccf500fa0d42a9d3d01790;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 3a1d1fd..668f7b9 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,9 @@ -;;; 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 +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,6 +34,8 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(require 'alist) +(require 'mime-view) (defgroup gnus-article nil "Article display." @@ -92,18 +95,24 @@ (defcustom gnus-ignored-headers '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:" - "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" + "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:" "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:" "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:" "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:" "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:" "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:" - "^NNTP-[-A-Za-z]*:" "^Distribution:" "^X-no-archive:" "^X-Trace:" + "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:" "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:" "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:" "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:" - "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" - "^X-Admin:" "^X-UID:") + "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" + "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" + "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" + "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" + "^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:") "*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." @@ -113,7 +122,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." @@ -266,8 +275,6 @@ 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")) (defcustom gnus-save-all-headers t @@ -369,19 +376,23 @@ be used as possible file names." (cons :value ("" "") regexp (repeat string)) (sexp :value nil)))) -(defcustom gnus-strict-mime t - "*If nil, MIME-decode even if there is no Mime-Version header." +(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 'boolean) + :type 'function) -(defcustom gnus-show-mime-method 'metamail-buffer - "Function to process a MIME message. +(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-decode-encoded-word-method 'gnus-article-de-quoted-unreadable - "*Function to decode MIME encoded words. +(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) @@ -393,7 +404,7 @@ beginning of a line." :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %%b %S" +(defcustom gnus-article-mode-line-format "Gnus: %g %S" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description." :type 'string @@ -540,8 +551,22 @@ displayed by the first non-nil matching CONTENT face." (item :tag "skip" nil) (face :value default))))) +(defcustom gnus-article-decode-hook nil + "*Hook run to decode charsets in articles." + :group 'gnus-article-headers + :type 'hook) + +(defcustom gnus-display-mime-function 'gnus-display-mime + "Function to display MIME articles." + :group 'gnus-article-headers + :type 'function) + +(defvar gnus-decode-header-function 'mail-decode-encoded-word-region + "Function used to decode headers.") + ;;; Internal variables +(defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) (defvar gnus-article-current-summary nil) @@ -664,7 +689,7 @@ always hide." (listp gnus-visible-headers)) (mapconcat 'identity gnus-visible-headers "\\|")))) (inhibit-point-motion-hooks t) - want-list beg) + beg) ;; First we narrow to just the headers. (widen) (goto-char (point-min)) @@ -757,13 +782,13 @@ 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"))) (when (and date - (< (gnus-days-between (current-time-string) date) + (< (days-between (current-time-string) date) 4)) (gnus-article-hide-header "date")))) ((eq elem 'long-to) @@ -801,7 +826,7 @@ always hide." (defun article-treat-dumbquotes () "Translate M******** sm*rtq**t*s into proper text." (interactive) - (article-translate-characters "\221\222\223\223" "`'\"\"")) + (article-translate-characters "\221\222\223\224" "`'\"\"")) (defun article-translate-characters (from to) "Translate all characters in the body of the article according to FROM and TO. @@ -885,7 +910,9 @@ characters to translate to." (point) (progn (while (and (not (bobp)) - (looking-at "^[ \t]*$")) + (looking-at "^[ \t]*$") + (not (gnus-annotation-in-region-p + (point) (gnus-point-at-eol)))) (forward-line -1)) (forward-line 1) (point)))))) @@ -899,24 +926,27 @@ characters to translate to." (delete-process "article-x-face")) (let ((inhibit-point-motion-hooks t) (case-fold-search t) - from) + from last) (save-restriction (nnheader-narrow-to-headers) (setq from (message-fetch-field "from")) (goto-char (point-min)) - ;; This used to try to do multiple faces (`while' instead of - ;; `when' below), but (a) sending multiple EOFs to xv doesn't - ;; work (b) it can crash some versions of Emacs (c) are - ;; multiple faces really something to encourage? - (when (and gnus-article-x-face-command - (or force - ;; Check whether this face is censored. - (not gnus-article-x-face-too-ugly) - (and gnus-article-x-face-too-ugly from - (not (string-match gnus-article-x-face-too-ugly - from)))) - ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) + (while (and gnus-article-x-face-command + (not last) + (or force + ;; Check whether this face is censored. + (not gnus-article-x-face-too-ugly) + (and gnus-article-x-face-too-ugly from + (not (string-match gnus-article-x-face-too-ugly + from)))) + ;; Has to be present. + (re-search-forward "^X-Face: " nil t)) + ;; This used to try to do multiple faces (`while' instead of + ;; `when' above), but (a) sending multiple EOFs to xv doesn't + ;; work (b) it can crash some versions of Emacs (c) are + ;; multiple faces really something to encourage? + (when (stringp gnus-article-x-face-command) + (setq last t)) ;; We now have the area of the buffer where the X-Face is stored. (save-excursion (let ((beg (point)) @@ -937,84 +967,74 @@ characters to translate to." (process-send-region "article-x-face" beg end) (process-send-eof "article-x-face")))))))))) -(defun gnus-hack-decode-rfc1522 () - "Emergency hack function for avoiding problems when decoding." - (let ((buffer-read-only nil)) - (goto-char (point-min)) - ;; Remove encoded TABs. - (while (search-forward "=09" nil t) - (replace-match " " t t)) - ;; Remove encoded newlines. - (goto-char (point-min)) - (while (search-forward "=10" nil t) - (replace-match " " t t)))) - -(defalias 'gnus-decode-rfc1522 'article-decode-rfc1522) -(defalias 'gnus-article-decode-rfc1522 'article-decode-rfc1522) -(defun article-decode-rfc1522 () - "Hack to remove QP encoding from headers." - (let ((case-fold-search t) - (inhibit-point-motion-hooks t) - (buffer-read-only nil) - string) +(defun 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) + (mail-decode-encoded-word-region (point-min) (point-max))))) + +(defun article-decode-charset (&optional prompt) + "Decode charset-encoded text in the article. +If PROMPT (the prefix), prompt for a coding system to use." + (interactive "P") + (save-excursion (save-restriction - (narrow-to-region - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - (goto-char (point-min)) - (while (re-search-forward - "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) - (setq string (match-string 1)) - (save-restriction - (narrow-to-region (match-beginning 0) (match-end 0)) - (delete-region (point-min) (point-max)) - (insert string) - (article-mime-decode-quoted-printable - (goto-char (point-min)) (point-max)) - (subst-char-in-region (point-min) (point-max) ?_ ? ) - (goto-char (point-max))) - (goto-char (point-min)))))) + (message-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 (condition-case () + (mail-header-parse-content-type ct) + (error nil)))) + (charset (cond + (prompt + (mm-read-coding-system "Charset to decode: ")) + (ctl + (mail-content-type-get ctl 'charset)) + (gnus-newsgroup-name + (gnus-group-find-parameter + gnus-newsgroup-name 'charset)))) + buffer-read-only) + (goto-char (point-max)) + (widen) + (forward-line 1) + (narrow-to-region (point) (point-max)) + (when (or (not ct) + (equal (car ctl) "text/plain")) + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))))))))) + +(defun article-decode-encoded-words () + "Remove encoded-word encoding from headers." + (let (buffer-read-only) + (let ((charset (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset))) + (eword-decode-header charset) + ))) (defun article-de-quoted-unreadable (&optional force) - "Do a naive translation of a quoted-printable-encoded article. -This is in no way, shape or form meant as a replacement for real MIME -processing, but is simply a stop-gap measure until MIME support is -written. + "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 ((case-fold-search t) - (buffer-read-only nil) + (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) - (article-mime-decode-quoted-printable (point) (point-max)))))) + (quoted-printable-decode-region (point) (point-max)))))) (defun article-mime-decode-quoted-printable-buffer () "Decode Quoted-Printable in the current buffer." - (article-mime-decode-quoted-printable (point-min) (point-max))) - -(defun article-mime-decode-quoted-printable (from to) - "Decode Quoted-Printable in the region between FROM and TO." - (interactive "r") - (goto-char from) - (while (search-forward "=" to t) - (cond ((eq (following-char) ?\n) - (delete-char -1) - (delete-char 1)) - ((looking-at "[0-9A-F][0-9A-F]") - (subst-char-in-region - (1- (point)) (point) ?= - (hexl-hex-string-to-integer - (buffer-substring (point) (+ 2 (point))))) - (delete-char 2)) - ((looking-at "=") - (delete-char 1)) - ((gnus-message 3 "Malformed MIME quoted-printable message"))))) + (quoted-printable-decode-region (point-min) (point-max))) (defun article-hide-pgp (&optional arg) "Toggle hiding of any PGP headers and signatures in the current article. @@ -1114,12 +1134,16 @@ always hide." (goto-char (point-min)) (search-forward "\n\n" nil t) (while (re-search-forward "^[ \t]+$" nil t) - (replace-match "" nil t)) + (unless (gnus-annotation-in-region-p + (match-beginning 0) (match-end 0)) + (replace-match "" nil t))) ;; Then replace multiple empty lines with a single empty line. (goto-char (point-min)) (search-forward "\n\n" nil t) (while (re-search-forward "\n\n\n+" nil t) - (replace-match "\n\n" t t))))) + (unless (gnus-annotation-in-region-p + (match-beginning 0) (match-end 0)) + (replace-match "\n\n" t t)))))) (defun article-strip-leading-space () "Remove all white space from the beginning of the lines in the article." @@ -1150,21 +1174,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 @@ -1222,7 +1235,7 @@ Put point at the beginning of the signature separator." (setq b (point)) (point-max)) (setq e (point-max))) - (nnheader-temp-write nil + (with-temp-buffer (insert-buffer-substring gnus-article-buffer b e) (require 'url) (save-window-excursion @@ -1263,8 +1276,7 @@ means show, 0 means toggle." (defun gnus-article-hidden-text-p (type) "Say whether the current buffer contains hidden text of type TYPE." - (let ((start (point-min)) - (pos (text-property-any (point-min) (point-max) 'article-type type))) + (let ((pos (text-property-any (point-min) (point-max) 'article-type type))) (while (and pos (not (get-text-property pos 'invisible))) (setq pos @@ -1345,103 +1357,92 @@ how much time has lapsed since DATE." (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (concat "Date: " (condition-case () - (timezone-make-date-arpa-standard date) - (error date)))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (condition-case () - (timezone-make-date-arpa-standard date nil "UT") - (error date)))) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " date)) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall - gnus-article-time-format - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT")))) + (let ((time (condition-case () + (date-to-time date) + (error '(0 0))))) + (cond + ;; Convert to the local timezone. We have to slap a + ;; `condition-case' round the calls to the timezone + ;; functions since they aren't particularly resistant to + ;; buggy dates. + ((eq type 'local) + (let ((tz (car (current-time-zone)))) + (format "Date: %s %s%04d" (current-time-string time) + (if (> tz 0) "+" "-") (abs (/ tz 36))))) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall gnus-article-time-format time) + (concat + "Date: " + (format-time-string gnus-article-time-format time)))) + ;; ISO 8601. + ((eq type 'iso8601) (concat "Date: " - (format-time-string gnus-article-time-format - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))))) - ;; ISO 8601. - ((eq type 'iso8601) - (concat - "Date: " - (format-time-string "%Y%M%DT%h%m%s" - (ignore-errors - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT")))))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time - (ignore-errors - (gnus-time-minus - (gnus-encode-date - (timezone-make-date-arpa-standard - (current-time-string now) - (current-time-zone now) "UT")) - (gnus-encode-date - (timezone-make-date-arpa-standard - date nil "UT"))))) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) - (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: Now") - (t - (concat - "X-Sent: " - ;; This is a bit convoluted, but basically we go - ;; through the time units for years, weeks, etc, - ;; and divide things to see whether that results - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - (t - (error "Unknown conversion type: %s" type)))) + (format-time-string "%Y%M%DT%h%m%s" time))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: Now") + (t + (concat + "X-Sent: " + ;; This is a bit convoluted, but basically we go + ;; through the time units for years, weeks, etc, + ;; and divide things to see whether that results + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + (t + (error "Unknown conversion type: %s" type))))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." @@ -1465,11 +1466,13 @@ function and want to see what the date was before converting." (let (deactivate-mark) (save-excursion (ignore-errors - (when (gnus-buffer-live-p gnus-article-buffer) - (set-buffer gnus-article-buffer) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t))))))) + (walk-windows + (lambda (w) + (set-buffer (window-buffer w)) + (when (eq major-mode 'gnus-article-mode) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t))))))))) (defun gnus-start-date-timer (&optional n) "Start a timer to update the X-Sent header in the article buffers. @@ -1555,7 +1558,7 @@ This format is defined by the `gnus-article-time-format' variable." (if (not gnus-default-article-saver) (error "No default saver is defined") ;; !!! Magic! The saving functions all save - ;; `gnus-original-article-buffer' (or so they think), but we + ;; `gnus-save-article-buffer' (or so they think), but we ;; bind that variable to our save-buffer. (set-buffer gnus-article-buffer) (let* ((gnus-save-article-buffer save-buffer) @@ -1672,7 +1675,7 @@ Directory to save to is default to `gnus-article-save-directory'." (save-excursion (save-restriction (widen) - (gnus-output-to-rmail filename)))) + (rmail-output-to-rmail-file filename)))) filename) (defun gnus-summary-save-in-mail (&optional filename) @@ -1689,7 +1692,7 @@ Directory to save to is default to `gnus-article-save-directory'." (widen) (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (gnus-output-to-rmail filename t) + (rmail-output-to-rmail-file filename t) (gnus-output-to-mail filename))))) filename) @@ -1850,8 +1853,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 @@ -1925,8 +1926,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["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 @@ -1967,7 +1967,7 @@ commands: (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) (gnus-set-default-directory) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq buffer-read-only t) (set-syntax-table gnus-article-mode-syntax-table) (gnus-run-hooks 'gnus-article-mode-hook)) @@ -1982,6 +1982,7 @@ commands: (substring name (match-end 0)))))) (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) + (setq gnus-article-mime-handle-alist nil) ;; This might be a variable local to the summary buffer. (unless gnus-single-article-buffer (save-excursion @@ -1992,13 +1993,12 @@ commands: ;; Init original article buffer. (save-excursion (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) - (buffer-disable-undo (current-buffer)) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) (if (get-buffer name) (save-excursion (set-buffer name) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) @@ -2024,6 +2024,44 @@ 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-prepare (article &optional all-headers header) "Prepare ARTICLE in article mode buffer. ARTICLE should either be an article number or a Message-ID. @@ -2036,12 +2074,12 @@ If ALL-HEADERS is non-nil, no headers are hidden." (setq gnus-summary-buffer (current-buffer)) (let* ((gnus-article (if header (mail-header-number header) article)) (summary-buffer (current-buffer)) - (internal-hook gnus-article-internal-prepare-hook) + (gnus-tmp-internal-hook gnus-article-internal-prepare-hook) (group gnus-newsgroup-name) 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) @@ -2117,21 +2155,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 '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 @@ -2145,6 +2169,219 @@ 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) + gnus-article-display-method-for-mime) + gnus-article-display-method-for-traditional))) + ;; Hooks for getting information from the article. + ;; This hook must be called before being narrowed. + (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 summary-buffer) + ;; Perform the article display hooks. + (gnus-run-hooks 'gnus-article-display-hook))) + +;;; +;;; Gnus MIME viewing functions +;;; + +(defvar gnus-mime-button-line-format "%{%([%p. %t%d%n]%)%}\n" + "The following specs can be used: +%t The MIME type +%n The `name' parameter +%d The description, if any +%l The length of the encoded part +%p The part identifier") + +(defvar gnus-mime-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?n gnus-tmp-name ?s) + (?d gnus-tmp-description ?s) + (?p gnus-tmp-id ?s) + (?l gnus-tmp-length ?d))) + +(defvar gnus-mime-button-map nil) +(unless gnus-mime-button-map + (setq gnus-mime-button-map (copy-keymap gnus-article-mode-map)) + (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) + (define-key gnus-mime-button-map "\r" 'gnus-article-press-button) + (define-key gnus-mime-button-map "\M-\r" 'gnus-mime-view-part) + (define-key gnus-mime-button-map "v" 'gnus-mime-view-part) + (define-key gnus-mime-button-map "o" 'gnus-mime-save-part) + (define-key gnus-mime-button-map "c" 'gnus-mime-copy-part) + (define-key gnus-mime-button-map "i" 'gnus-mime-inline-part) + (define-key gnus-mime-button-map "|" 'gnus-mime-pipe-part)) + +(defun gnus-mime-view-all-parts () + "View all the MIME parts." + (interactive) + (let ((handles gnus-article-mime-handles)) + (while handles + (mm-display-part (pop handles))))) + +(defun gnus-mime-save-part () + "Save the MIME part under point." + (interactive) + (let ((data (get-text-property (point) 'gnus-data))) + (mm-save-part data))) + +(defun gnus-mime-pipe-part () + "Pipe the MIME part under point to a process." + (interactive) + (let ((data (get-text-property (point) 'gnus-data))) + (mm-pipe-part data))) + +(defun gnus-mime-view-part () + "Interactively choose a view method for the MIME part under point." + (interactive) + (let ((data (get-text-property (point) 'gnus-data)) + (url-standalone-mode (not gnus-plugged))) + (mm-interactively-view-part data))) + +(defun gnus-mime-copy-part () + "Put the the MIME part under point into a new buffer." + (interactive) + (let* ((data (get-text-property (point) 'gnus-data)) + (contents (mm-get-part data))) + (switch-to-buffer (generate-new-buffer "*decoded*")) + (insert contents) + (goto-char (point-min)))) + +(defun gnus-mime-inline-part () + "Insert the MIME part under point into the current buffer." + (interactive) + (let* ((data (get-text-property (point) 'gnus-data)) + (contents (mm-get-part data)) + (url-standalone-mode (not gnus-plugged)) + (b (point)) + buffer-read-only) + (if (mm-handle-undisplayer data) + (mm-remove-part data) + (forward-line 2) + (mm-insert-inline data contents) + (goto-char b)))) + +(defun gnus-article-view-part (n) + "View MIME part N, which is the numerical prefix." + (interactive "p") + (save-current-buffer + (set-buffer gnus-article-buffer) + (when (> n (length gnus-article-mime-handle-alist)) + (error "No such part")) + (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) + (gnus-article-goto-part n) + (mm-display-part handle)))) + +(defun gnus-article-goto-part (n) + "Go to MIME part N." + (goto-char (text-property-any (point-min) (point-max) 'gnus-part n))) + +(defun gnus-insert-mime-button (handle) + (let ((gnus-tmp-name (mail-content-type-get (mm-handle-type handle) 'name)) + (gnus-tmp-type (car (mm-handle-type handle))) + (gnus-tmp-description (mm-handle-description handle)) + (gnus-tmp-length (save-excursion + (set-buffer (mm-handle-buffer handle)) + (buffer-size))) + (gnus-tmp-id (1+ (length gnus-article-mime-handle-alist))) + b e) + (push (cons gnus-tmp-id handle) gnus-article-mime-handle-alist) + (setq gnus-tmp-name + (if gnus-tmp-name + (concat " (" gnus-tmp-name ")") + "")) + (setq gnus-tmp-description + (if gnus-tmp-description + (concat " (" gnus-tmp-description ")") + "")) + (setq b (point)) + (gnus-eval-format + gnus-mime-button-line-format gnus-mime-button-line-format-alist + `(local-map ,gnus-mime-button-map + keymap ,gnus-mime-button-map + gnus-callback mm-display-part + gnus-part ,gnus-tmp-id + gnus-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button 'link from to :action 'gnus-widget-press-button + :button-keymap gnus-widget-button-keymap))) + +(defun gnus-widget-press-button (elems el) + (goto-char (widget-get elems :from)) + (let ((url-standalone-mode (not gnus-plugged))) + (gnus-article-press-button))) + +(defun gnus-display-mime () + "Insert MIME buttons in the buffer." + (let (ct ctl) + (save-restriction + (mail-narrow-to-head) + (when (setq ct (mail-fetch-field "content-type")) + (setq ctl (condition-case () + (mail-header-parse-content-type ct) (error nil))))) + (let* ((handles (mm-dissect-buffer)) + handle name type b e) + (mapcar 'mm-destroy-part gnus-article-mime-handles) + (setq gnus-article-mime-handles handles + gnus-article-mime-handle-alist nil) + (when handles + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (delete-region (point) (point-max)) + (if (not (equal (car ctl) "multipart/alternative")) + (while (setq handle (pop handles)) + (gnus-insert-mime-button handle) + (insert "\n\n") + (when (and (mm-automatic-display-p + (car (mm-handle-type handle))) + (mm-inlinable-part-p (car (mm-handle-type handle))) + (or (not (mm-handle-disposition handle)) + (equal (car (mm-handle-disposition handle)) + "inline"))) + (forward-line -2) + (mm-display-part handle t) + (goto-char (point-max)))) + ;; Here we have multipart/alternative + (gnus-mime-display-alternative handles)))))) + +(defun gnus-mime-display-alternative (handles &optional preferred) + (let* ((preferred (mm-preferred-alternative handles preferred)) + (ihandles handles) + handle buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (delete-region (point) (point-max)) + (mapcar 'mm-remove-part gnus-article-mime-handles) + (setq gnus-article-mime-handles handles) + (while (setq handle (pop handles)) + (gnus-add-text-properties + (point) + (progn + (insert (format "[%c] %-18s" + (if (equal handle preferred) ?* ? ) + (car (mm-handle-type handle)))) + (point)) + `(local-map ,gnus-mime-button-map + ,gnus-mouse-face-prop ,gnus-article-mouse-face + face ,gnus-article-button-face + keymap ,gnus-mime-button-map + gnus-callback + (lambda (handles) + (gnus-mime-display-alternative + ',ihandles ,(car (mm-handle-type handle)))) + gnus-data ,handle)) + (insert " ")) + (insert "\n\n") + (when preferred + (mm-display-part preferred)))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -2181,7 +2418,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))) - (nnheader-temp-write nil + (with-temp-buffer (insert-buffer-substring artbuf) ;; Append newline at end of the buffer as separator, and then ;; save it to file. @@ -2500,15 +2737,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))) @@ -2554,13 +2782,18 @@ If given a prefix, show the hidden text instead." (if (get-buffer gnus-original-article-buffer) (set-buffer gnus-original-article-buffer) (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) - (buffer-disable-undo (current-buffer)) + (buffer-disable-undo) (setq major-mode 'gnus-original-article-mode) (setq buffer-read-only t)) (let (buffer-read-only) (erase-buffer) (insert-buffer-substring gnus-article-buffer)) - (setq gnus-original-article (cons group article)))) + (setq gnus-original-article (cons group article))) + + ;; Decode charsets. + (run-hooks 'gnus-article-decode-hook) + ;; Mark article as decoded or not. + (setq gnus-article-decoded-p gnus-article-decode-hook)) ;; Update sparse articles. (when (and do-update-line @@ -2705,11 +2938,10 @@ groups." (setq gnus-original-article nil))) (set-window-configuration winconf) ;; Tippy-toe some to make sure that point remains where it was. - (let ((buf (current-buffer))) + (save-current-buffer (set-buffer curbuf) (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p) - (set-buffer buf))))) + (goto-char p))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -2744,7 +2976,7 @@ groups." ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([a-zA-Z.-@_+0-9%]+\\)" 0 t gnus-url-mailto 1) + ("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... ("]*\\)>" 0 t gnus-button-embedded-url 1) @@ -3127,7 +3359,7 @@ specified by `gnus-button-alist'." (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) - (setq pairs (gnus-split-string query "&")) + (setq pairs (split-string query "&")) (while pairs (setq cur (car pairs) pairs (cdr pairs)) @@ -3179,7 +3411,7 @@ forbidden in URL encoding." ;; Send mail to someone (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) - (let (to args source-url subject func) + (let (to args subject func) (if (string-match (regexp-quote "?") url) (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) args (gnus-url-parse-query-string @@ -3187,26 +3419,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." @@ -3288,6 +3523,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)