X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=3e2d86bc7ea72865d128cfe3a0cd7a01b6cbb241;hb=41fb7027bd9100cf7a76b88761ed42317e11cfa8;hp=d3b2357a318a7038f604295cd668b10ecdb2a2ee;hpb=517d8c1e72ed898204ef80597cda8084746d52c3;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index d3b2357..3e2d86b 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,8 +1,10 @@ -;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;;; gnus-art.el --- article mode commands for Semi-gnus +;; Copyright (C) 1996,97,98,99 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,12 +35,31 @@ (require 'gnus-spec) (require 'gnus-int) (require 'browse-url) +(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." :link '(custom-manual "(gnus)The Article Buffer") :group 'gnus) +(defgroup gnus-article-treat nil + "Treating article parts." + :link '(custom-manual "(gnus)Article Hiding") + :group 'gnus-article) + (defgroup gnus-article-hiding nil "Hiding article parts." :link '(custom-manual "(gnus)Article Hiding") @@ -92,7 +113,7 @@ (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:" @@ -102,7 +123,7 @@ "^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:" + "^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:" @@ -119,7 +140,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:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-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,7 +293,6 @@ be fed to `format-time-string'." :group 'gnus-article-washing) (eval-and-compile - (autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-extract-address-components "mail-extr")) (defcustom gnus-save-all-headers t @@ -374,19 +394,16 @@ 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." - :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-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) @@ -398,9 +415,14 @@ 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%m" "*The format specification for the article mode line. -See `gnus-summary-mode-line-format' for a closer description." +See `gnus-summary-mode-line-format' for a closer description. + +The following additional specs are available: + +%w The article washing status. +%m The number of MIME parts in the article." :type 'string :group 'gnus-article-various) @@ -545,8 +567,239 @@ 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-mime + :type 'function) + +(defvar gnus-decode-header-function 'mail-decode-encoded-word-region + "Function used to decode headers.") + +(defvar gnus-article-dumbquotes-map + '(("\202" ",") + ("\203" "f") + ("\204" ",,") + ("\205" "...") + ("\213" "<") + ("\214" "OE") + ("\221" "`") + ("\222" "'") + ("\223" "``") + ("\224" "''") + ("\225" "*") + ("\226" "-") + ("\227" "-") + ("\231" "(TM)") + ("\233" ">") + ("\234" "oe") + ("\264" "'")) + "Table for MS-to-Latin1 translation.") + +(defcustom gnus-ignored-mime-types nil + "List of MIME types that should be ignored by Gnus." + :group 'gnus-article-mime + :type '(repeat regexp)) + +(defcustom gnus-unbuttonized-mime-types '(".*/.*") + "List of MIME types that should not be given buttons when rendered." + :group 'gnus-article-mime + :type '(repeat regexp)) + +(defcustom gnus-article-mime-part-function nil + "Function called with a MIME handle as the argument. + This is meant for people who want to do something automatic based + on parts -- for instance, adding Vcard info to a database." + :group 'gnus-article-mime + :type 'function) + +;;; +;;; The treatment variables +;;; + +(defvar gnus-article-treat-custom + '(choice (const :tag "Off" nil) + (const :tag "On" t) + (const :tag "Header" head) + (const :tag "Last" last) + (integer :tag "Less") + (sexp :tag "Predicate"))) + +(defvar gnus-article-treat-types '("text/plain") + "Parts to treat.") + +(defvar gnus-inhibit-treatment nil + "Whether to inhibit treatment.") + +(defcustom gnus-treat-highlight-signature 'last + "Highlight the signature." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-buttonize t + "Add buttons." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-buttonize-head 'head + "Add buttons to the head." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-emphasize t + "Emphasize text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-cr nil + "Remove carriage returns." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-headers 'head + "Hide headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-boring-headers nil + "Hide boring headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-signature nil + "Hide the signature." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-fill-article nil + "Fill the article." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-hide-citation nil + "Hide cited text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pgp t + "Strip PGP signatures." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-pem nil + "Strip PEM signatures." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-highlight-headers 'head + "Highlight the headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-highlight-citation t + "Highlight cited text." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-ut nil + "Display the Date in UT (GMT)." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-local nil + "Display the Date in the local timezone." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-lapsed nil + "Display the Date header in a way that says how much time has elapsed." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-date-original nil + "Display the date in the original timezone." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-trailing-blank-lines nil + "Strip trailing blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-leading-blank-lines nil + "Strip leading blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-multiple-blank-lines nil + "Strip multiple blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-strip-blank-lines nil + "Strip all blank lines." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-overstrike t + "Treat overstrike highlighting." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-xface (if gnus-xemacs 'head nil) + "Display X-Face headers." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-smileys (if gnus-xemacs t nil) + "Display smileys." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + +(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) + "Display picons." + :group 'gnus-article + :type gnus-article-treat-custom) + ;;; Internal variables +(defvar gnus-article-mime-handle-alist-1 nil) +(defvar gnus-treatment-function-alist + '((gnus-treat-highlight-signature gnus-article-highlight-signature) + (gnus-treat-buttonize gnus-article-add-buttons) + (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) + (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-fill-article gnus-article-fill-cited-article) + (gnus-treat-strip-cr gnus-article-remove-cr) + (gnus-treat-hide-headers gnus-article-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-strip-pgp gnus-article-hide-pgp) + (gnus-treat-strip-pem gnus-article-hide-pem) + (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-date-ut gnus-article-date-ut) + (gnus-treat-date-local gnus-article-date-local) + (gnus-treat-date-lapsed gnus-article-date-lapsed) + (gnus-treat-date-original gnus-article-date-original) + (gnus-treat-strip-trailing-blank-lines + gnus-article-remove-trailing-blank-lines) + (gnus-treat-strip-leading-blank-lines + gnus-article-strip-leading-blank-lines) + (gnus-treat-strip-multiple-blank-lines + gnus-article-strip-multiple-blank-lines) + (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines) + (gnus-treat-overstrike gnus-article-treat-overstrike) + (gnus-treat-display-xface gnus-article-display-x-face) + (gnus-treat-display-smileys gnus-smiley-display))) + +(defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) (defvar gnus-article-current-summary nil) @@ -562,7 +815,8 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-save-article-buffer nil) (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s)) + (nconc '((?w (gnus-article-wash-status) ?s) + (?m (gnus-article-mime-part-status) ?s)) gnus-summary-mode-line-format-alist)) (defvar gnus-number-of-articles-to-be-saved nil) @@ -577,6 +831,33 @@ Initialized from `text-mode-syntax-table.") (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) @@ -762,13 +1043,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) @@ -803,18 +1084,50 @@ always hide." (point-max))) 'boring-headers)))) +(defvar gnus-article-normalized-header-length 40 + "Length of normalized headers.") + +(defun article-normalize-headers () + "Make all header lines 40 characters long." + (interactive) + (let ((buffer-read-only nil) + column) + (save-excursion + (save-restriction + (message-narrow-to-head) + (while (not (eobp)) + (cond + ((< (setq column (- (gnus-point-at-eol) (point))) + gnus-article-normalized-header-length) + (end-of-line) + (insert (make-string + (- gnus-article-normalized-header-length column) + ? ))) + ((> column gnus-article-normalized-header-length) + (gnus-put-text-property + (progn + (forward-char gnus-article-normalized-header-length) + (point)) + (gnus-point-at-eol) + 'invisible t)) + (t + ;; Do nothing. + )) + (forward-line 1)))))) + (defun article-treat-dumbquotes () - "Translate M******** sm*rtq**t*s into proper text." + "Translate M******** sm*rtq**t*s into proper text. +Note that this function guesses whether a character is a sm*rtq**t* or +not, so it should only be used interactively." (interactive) - (article-translate-characters "\221\222\223\223" "`'\"\"")) + (article-translate-strings gnus-article-dumbquotes-map)) (defun article-translate-characters (from to) "Translate all characters in the body of the article according to FROM and TO. FROM is a string of characters to translate from; to is a string of characters to translate to." (save-excursion - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (article-goto-body) (let ((buffer-read-only nil) (x (make-string 225 ?x)) (i -1)) @@ -826,15 +1139,26 @@ characters to translate to." (incf i)) (translate-region (point) (point-max) x))))) +(defun article-translate-strings (map) + "Translate all string in the body of the article according to MAP. +MAP is an alist where the elements are on the form (\"from\" \"to\")." + (save-excursion + (when (article-goto-body) + (let ((buffer-read-only nil) + elem) + (while (setq elem (pop map)) + (save-excursion + (while (search-forward (car elem) nil t) + (replace-match (cadr elem))))))))) + (defun article-treat-overstrike () "Translate overstrikes into bold text." (interactive) (save-excursion - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (article-goto-body) (let ((buffer-read-only nil)) (while (search-forward "\b" nil t) - (let ((next (following-char)) + (let ((next (char-after)) (previous (char-after (- (point) 2)))) ;; We do the boldification/underlining by hiding the ;; overstrikes and putting the proper text property @@ -859,8 +1183,7 @@ characters to translate to." (save-excursion (let ((buffer-read-only nil)) (widen) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (end-of-line 1) (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$") (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?") @@ -872,13 +1195,16 @@ characters to translate to." (end-of-line 2)))))) (defun article-remove-cr () - "Remove carriage returns from an article." + "Translate CRLF pairs into LF, and then CR into LF.." (interactive) (save-excursion (let ((buffer-read-only nil)) (goto-char (point-min)) + (while (search-forward "\r$" nil t) + (replace-match "" t t)) + (goto-char (point-min)) (while (search-forward "\r" nil t) - (replace-match "" t t))))) + (replace-match "\n" t t))))) (defun article-remove-trailing-blank-lines () "Remove all trailing blank lines from the article." @@ -890,7 +1216,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)))))) @@ -945,24 +1273,57 @@ characters to translate to." (process-send-region "article-x-face" beg end) (process-send-eof "article-x-face")))))))))) -(defun gnus-article-decode-mime-words () +(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) - (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)) + buffer-read-only + (mail-parse-charset gnus-newsgroup-charset)) + (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 (message-narrow-to-head) - (rfc2047-decode-region (point-min) (point-max))))) + (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)))) + (mail-parse-charset gnus-newsgroup-charset) + buffer-read-only) + (goto-char (point-max)) + (widen) + (forward-line 1) + (narrow-to-region (point) (point-max)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain")) + (not (mm-uu-test))) + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) + +(defun article-decode-encoded-words () + "Remove encoded-word encoding from headers." + (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. @@ -971,17 +1332,16 @@ or not." (interactive (list 'force)) (save-excursion (let ((buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding"))) - (gnus-article-decode-rfc1522) + (type (gnus-fetch-field "content-transfer-encoding")) + (charset gnus-newsgroup-charset)) (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))) + (article-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (quoted-printable-decode-region (point-min) (point-max)) + (when charset + (mm-decode-body charset))))))) (defun article-hide-pgp (&optional arg) "Toggle hiding of any PGP headers and signatures in the current article. @@ -997,6 +1357,9 @@ always hide." ;; Hide the "header". (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) (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) @@ -1065,12 +1428,19 @@ always hide." (save-excursion (let ((inhibit-point-motion-hooks t) buffer-read-only) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (article-goto-body) (while (and (not (eobp)) (looking-at "[ \t]*$")) (gnus-delete-line)))))) +(defun article-goto-body () + "Place point at the start of the body." + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + t + (goto-char (point-max)) + nil)) + (defun article-strip-multiple-blank-lines () "Replace consecutive blank lines with one empty line." (interactive) @@ -1078,15 +1448,17 @@ always hide." (let ((inhibit-point-motion-hooks t) buffer-read-only) ;; First make all blank lines empty. - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (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) + (article-goto-body) (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." @@ -1094,11 +1466,20 @@ always hide." (save-excursion (let ((inhibit-point-motion-hooks t) buffer-read-only) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (while (re-search-forward "^[ \t]+" nil t) (replace-match "" t t))))) +(defun article-strip-trailing-space () + "Remove all white space from the end of the lines in the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (article-goto-body) + (while (re-search-forward "[ \t]+$" nil t) + (replace-match "" t t))))) + (defun article-strip-blank-lines () "Strip leading, trailing and multiple blank lines." (interactive) @@ -1112,26 +1493,14 @@ always hide." (save-excursion (let ((inhibit-point-motion-hooks t) buffer-read-only) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (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 @@ -1237,7 +1606,7 @@ means show, 0 means toggle." (text-property-any (1+ pos) (point-max) 'article-type type))) (if pos 'hidden - 'shown))) + nil))) (defun gnus-article-show-hidden-text (type &optional hide) "Show all hidden text of type TYPE. @@ -1273,7 +1642,9 @@ If TYPE is `local', convert to local time; if it is `lapsed', output how much time has lapsed since DATE." (interactive (list 'ut t)) (let* ((header (or header - (mail-header-date gnus-current-headers) + (mail-header-date (save-excursion + (set-buffer gnus-summary-buffer) + gnus-current-headers)) (message-fetch-field "date") "")) (date (if (vectorp header) (mail-header-date header) @@ -1311,103 +1682,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." @@ -1431,11 +1791,14 @@ 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)))) + nil 'visible))))) (defun gnus-start-date-timer (&optional n) "Start a timer to update the X-Sent header in the article buffers. @@ -1483,8 +1846,7 @@ This format is defined by the `gnus-article-time-format' variable." (props (append '(article-type emphasis) gnus-hidden-properties)) regexp elem beg invisible visible face) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (setq beg (point)) (while (setq elem (pop alist)) (goto-char beg) @@ -1521,7 +1883,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) @@ -1655,7 +2017,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) @@ -1695,8 +2057,7 @@ The directory to save in defaults to `gnus-article-save-directory'." (save-excursion (save-restriction (widen) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) + (when (article-goto-body) (narrow-to-region (point) (point-max))) (gnus-output-to-file filename)))) filename) @@ -1704,7 +2065,8 @@ The directory to save in defaults to `gnus-article-save-directory'." (defun gnus-summary-save-in-pipe (&optional command) "Pipe this article to subprocess." (setq command - (cond ((eq command 'default) + (cond ((and (eq command 'default) + gnus-last-shell-command) gnus-last-shell-command) (command command) (t (read-string @@ -1825,16 +2187,21 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-strip-leading-blank-lines article-strip-multiple-blank-lines article-strip-leading-space + article-strip-trailing-space article-strip-blank-lines article-strip-all-blank-lines article-date-local article-date-iso8601 article-date-original article-date-ut + article-decode-mime-words + article-decode-charset + article-decode-encoded-words article-date-user article-date-lapsed article-emphasize article-treat-dumbquotes + article-normalize-headers (article-show-all . gnus-article-show-all-headers)))) ;;; @@ -1868,8 +2235,28 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\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) @@ -1891,8 +2278,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 @@ -1932,12 +2318,13 @@ commands: (make-local-variable 'gnus-page-broken) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) + (make-local-variable 'gnus-article-mime-handles) + (make-local-variable 'gnus-article-decoded-p) + (make-local-variable 'gnus-article-mime-handle-alist) (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) - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte t)) (gnus-run-hooks 'gnus-article-mode-hook)) (defun gnus-article-setup-buffer () @@ -1950,6 +2337,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 @@ -1960,13 +2348,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)) @@ -1975,6 +2362,7 @@ commands: (set-buffer (gnus-get-buffer-create name)) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) + (gnus-summary-set-local-parameters gnus-newsgroup-name) (current-buffer))))) ;; Set article window start at LINE, where LINE is the number of lines @@ -1992,6 +2380,70 @@ 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 (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) + (mime-display-message mime-message-structure + gnus-article-buffer nil gnus-article-mode-map) + (when all-headers + (gnus-article-hide-headers nil -1)) + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + ) + ;; `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. @@ -2009,7 +2461,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) @@ -2047,7 +2499,9 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-configure-windows 'summary) (gnus-configure-windows 'article)) (gnus-set-global-variables)) - (gnus-set-mode-line 'article)) + (let ((gnus-article-mime-handle-alist-1 + gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article))) ;; The result from the `request' was an actual article - ;; or at least some text that is now displayed in the ;; article buffer. @@ -2085,34 +2539,566 @@ 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 (when gnus-break-pages (gnus-narrow-to-page) t))) - (gnus-set-mode-line 'article) + (let ((gnus-article-mime-handle-alist-1 + gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)) (gnus-configure-windows 'article) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + (article-goto-body) (set-window-point (get-buffer-window (current-buffer)) (point)) t)))))) +;;;###autoload +(defun gnus-article-prepare-display () + "Make the current buffer look like a nice article." + (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) + ;; 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 +;;; + +(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n" + "The following specs can be used: +%t The MIME type +%T MIME type, along with additional info +%n The `name' parameter +%d The description, if any +%l The length of the encoded part +%p The part identifier number +%e Dots if the part isn't displayed") + +(defvar gnus-mime-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?T gnus-tmp-type-long ?s) + (?n gnus-tmp-name ?s) + (?d gnus-tmp-description ?s) + (?p gnus-tmp-id ?s) + (?l gnus-tmp-length ?d) + (?e gnus-tmp-dots ?s))) + +(defvar gnus-mime-button-commands + '((gnus-article-press-button "\r" "Toggle Display") + (gnus-mime-view-part "v" "View Interactively...") + (gnus-mime-save-part "o" "Save...") + (gnus-mime-copy-part "c" "View As Text, In Other Buffer") + (gnus-mime-inline-part "i" "View As Text, In This Buffer") + (gnus-mime-internalize-part "E" "View Internally") + (gnus-mime-externalize-part "e" "View Externally") + (gnus-mime-pipe-part "|" "Pipe To Command..."))) + +(defun gnus-article-mime-part-status () + (if gnus-article-mime-handle-alist-1 + (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) + "")) + +(defvar gnus-mime-button-map nil) +(unless gnus-mime-button-map + (setq gnus-mime-button-map (make-sparse-keymap)) + (set-keymap-parent gnus-mime-button-map gnus-article-mode-map) + (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) + (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu) + (mapcar (lambda (c) + (define-key gnus-mime-button-map (cadr c) (car c))) + gnus-mime-button-commands)) + +(defun gnus-mime-button-menu (event) + "Construct a context-sensitive menu of MIME commands." + (interactive "e") + (save-excursion + (let ((pos (event-start event))) + (set-buffer (window-buffer (posn-window pos))) + (goto-char (posn-point pos)) + (gnus-article-check-buffer) + (let ((response (x-popup-menu + t `("MIME Part" + ("" ,@(mapcar (lambda (c) + (cons (caddr c) (car c))) + gnus-mime-button-commands)))))) + (if response + (funcall response)))))) + +(defun gnus-mime-view-all-parts (&optional handles) + "View all the MIME parts." + (interactive) + (save-current-buffer + (set-buffer gnus-article-buffer) + (let ((handles (or handles gnus-article-mime-handles)) + (mail-parse-charset gnus-newsgroup-charset)) + (if (stringp (car handles)) + (gnus-mime-view-all-parts (cdr handles)) + (mapcar 'mm-display-part handles))))) + +(defun gnus-mime-save-part () + "Save the MIME part under point." + (interactive) + (gnus-article-check-buffer) + (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) + (gnus-article-check-buffer) + (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) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-data))) + (mm-interactively-view-part data))) + +(defun gnus-mime-copy-part (&optional handle) + "Put the the MIME part under point into a new buffer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (contents (mm-get-part handle))| + (base (file-name-nondirectory + (or + (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-type handle) + 'filename) + "*decoded*"))) + (buffer (generate-new-buffer base))) + (switch-to-buffer buffer) + (insert contents) + ;; We do it this way to make `normal-mode' set the appropriate mode. + (unwind-protect + (progn + (setq buffer-file-name (expand-file-name base)) + (normal-mode)) + (setq buffer-file-name nil)) + (goto-char (point-min)))) + +(defun gnus-mime-inline-part (&optional charset) + "Insert the MIME part under point into the current buffer." + (interactive "P") ; For compatibility reasons we are not using "z". + (gnus-article-check-buffer) + (let* ((data (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)) + (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) + (goto-char b)))) + +(defun gnus-mime-externalize-part (&optional handle) + "View the MIME part under point with an external viewer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (mm-user-display-methods nil) + (mm-all-images-fit t) + (mail-parse-charset gnus-newsgroup-charset)) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle)))) + +(defun gnus-mime-internalize-part (&optional handle) + "View the MIME part under point with an internal viewer." + (interactive) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + (mm-user-display-methods '((".*" . inline))) + (mm-all-images-fit t) + (mail-parse-charset gnus-newsgroup-charset)) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle) + (mm-display-part handle)))) + +(defun gnus-article-part-wrapper (n function) + (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)))) + (funcall function handle)))) + +(defun gnus-article-pipe-part (n) + "Pipe MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'mm-pipe-part)) + +(defun gnus-article-save-part (n) + "Save MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'mm-save-part)) + +(defun gnus-article-interactively-view-part (n) + "Pipe MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'mm-interactively-view-part)) + +(defun gnus-article-copy-part (n) + "Pipe MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-copy-part)) + +(defun gnus-article-externalize-part (n) + "Pipe MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-externalize-part)) + +(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)))) + (when (gnus-article-goto-part n) + (if (equal (car handle) "multipart/alternative") + (gnus-article-press-button) + (when (eq (gnus-mm-display-part handle) 'internal) + (gnus-set-window-start))))))) + +(defun gnus-mm-display-part (handle) + "Display HANDLE and fix MIME button." + (let ((id (get-text-property (point) 'gnus-part)) + (point (point)) + buffer-read-only) + (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) + (gnus-insert-mime-button + handle id (list (not (mm-handle-displayed-p handle)))) + (prog1 + (let ((window (selected-window)) + (mail-parse-charset gnus-newsgroup-charset)) + (save-excursion + (unwind-protect + (let ((win (get-buffer-window (current-buffer) t)) + (beg (point))) + (when win + (select-window win)) + (goto-char point) + (forward-line) + (if (mm-handle-displayed-p handle) + (mm-display-part handle) + (save-restriction + (narrow-to-region (point) (1+ (point))) + (mm-display-part handle) + (gnus-treat-article + nil id + (1- (length gnus-article-mime-handles)) + (car (mm-handle-type handle)))))) + (select-window window)))) + (goto-char point)))) + +(defun gnus-article-goto-part (n) + "Go to MIME part N." + (let ((point (text-property-any (point-min) (point-max) 'gnus-part n))) + (when point + (goto-char point)))) + +(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) + (let ((gnus-tmp-name + (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename) + "")) + (gnus-tmp-type (car (mm-handle-type handle))) + (gnus-tmp-description + (mail-decode-encoded-word-string (or (mm-handle-description handle) + ""))) + (gnus-tmp-dots + (if (if displayed (car displayed) + (mm-handle-displayed-p handle)) + "" "...")) + (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) + (buffer-size))) + gnus-tmp-type-long b e) + (when (string-match ".*/" gnus-tmp-name) + (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) + (setq gnus-tmp-type-long (concat gnus-tmp-type + (and (not (equal gnus-tmp-name "")) + (concat "; " gnus-tmp-name)))) + (or (equal gnus-tmp-description "") + (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (unless (bolp) + (insert "\n")) + (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 gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map + :help-echo + (lambda (widget) + ;; Needed to properly clear the message + ;; due to a bug in wid-edit + (setq help-echo-owns-message t) + (format + "Click to %s the MIME part; %s for more options" + (if (mm-handle-displayed-p + (widget-get widget :mime-handle)) + "hide" "show") + (if gnus-xemacs "button3" "mouse-3")))))) + +(defun gnus-widget-press-button (elems el) + (goto-char (widget-get elems :from)) + (gnus-article-press-button)) + +(defun gnus-display-mime (&optional ihandles) + "Display the MIME parts." + (save-excursion + (save-selected-window + (let ((window (get-buffer-window gnus-article-buffer)) + (point (point))) + (when window + (select-window window) + ;; We have to do this since selecting the window + ;; may change the point. So we set the window point. + (set-window-point window point))) + (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect))) + handle name type b e display) + (unless ihandles + ;; Top-level call; we clean up. + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles handles + gnus-article-mime-handle-alist nil) + ;; We allow users to glean info from the handles. + (when gnus-article-mime-part-function + (gnus-mime-part-function handles))) + (if (and handles + (or (not (stringp (car handles))) + (cdr handles))) + (progn + (unless ihandles + ;; Clean up for mime parts. + (article-goto-body) + (delete-region (point) (point-max))) + (gnus-mime-display-part handles)) + (save-restriction + (article-goto-body) + (narrow-to-region (point) (point-max)) + (gnus-treat-article nil 1 1))) + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (narrow-to-region (point-min) (point)) + (gnus-treat-article 'head))))))) + +(defvar gnus-mime-display-multipart-as-mixed nil) + +(defun gnus-mime-display-part (handle) + (cond + ;; Single part. + ((not (stringp (car handle))) + (gnus-mime-display-single handle)) + ;; multipart/alternative + ((and (equal (car handle) "multipart/alternative") + (not gnus-mime-display-multipart-as-mixed)) + (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (push (cons id handle) gnus-article-mime-handle-alist) + (gnus-mime-display-alternative (cdr handle) nil nil id))) + ;; multipart/related + ((and (equal (car handle) "multipart/related") + (not gnus-mime-display-multipart-as-mixed)) + ;;;!!!We should find the start part, but we just default + ;;;!!!to the first part. + (gnus-mime-display-part (cadr handle))) + ;; Other multiparts are handled like multipart/mixed. + (t + (gnus-mime-display-mixed (cdr handle))))) + +(defun gnus-mime-part-function (handles) + (if (stringp (car handles)) + (mapcar 'gnus-mime-part-function (cdr handles)) + (funcall gnus-article-mime-part-function handles))) + +(defun gnus-mime-display-mixed (handles) + (mapcar 'gnus-mime-display-part handles)) + +(defun gnus-mime-display-single (handle) + (let ((type (car (mm-handle-type handle))) + (ignored gnus-ignored-mime-types) + (not-attachment t) + (move nil) + display text) + (catch 'ignored + (progn + (while ignored + (when (string-match (pop ignored) type) + (throw 'ignored nil))) + (if (and (setq not-attachment + (or (not (mm-handle-disposition handle)) + (equal (car (mm-handle-disposition handle)) + "inline"))) + (mm-automatic-display-p type) + (or (mm-inlinable-part-p type) + (mm-automatic-external-display-p type))) + (setq display t) + (when (equal (car (split-string type "/")) + "text") + (setq text t))) + (let ((id (1+ (length gnus-article-mime-handle-alist)))) + (push (cons id handle) gnus-article-mime-handle-alist) + (when (or (not display) + (not (gnus-unbuttonized-mime-type-p type))) + (gnus-article-insert-newline) + (gnus-insert-mime-button + handle id (list (or display (and not-attachment text)))) + (gnus-article-insert-newline) + (gnus-article-insert-newline) + (setq move t))) + (let ((beg (point))) + (cond + (display + (when move + (forward-line -2)) + (let ((mail-parse-charset gnus-newsgroup-charset)) + (mm-display-part handle t)) + (goto-char (point-max))) + ((and text not-attachment) + (when move + (forward-line -2)) + (gnus-article-insert-newline) + (mm-insert-inline handle (mm-get-part handle)) + (goto-char (point-max)))) + ;; Do highlighting. + (save-excursion + (save-restriction + (narrow-to-region beg (point)) + (gnus-treat-article + nil (length gnus-article-mime-handle-alist) + (1- (length gnus-article-mime-handles)) + (car (mm-handle-type handle)))))))))) + +(defun gnus-unbuttonized-mime-type-p (type) + "Say whether TYPE is to be unbuttonized." + (unless gnus-inhibit-mime-unbuttonizing + (catch 'found + (let ((types gnus-unbuttonized-mime-types)) + (while types + (when (string-match (pop types) type) + (throw 'found t))))))) + +(defun gnus-article-insert-newline () + "Insert a newline, but mark it as undeletable." + (gnus-put-text-property + (point) (progn (insert "\n") (point)) 'gnus-undeletable t)) + +(defun gnus-mime-display-alternative (handles &optional preferred ibegend id) + (let* ((preferred (or preferred (mm-preferred-alternative handles))) + (ihandles handles) + (point (point)) + handle buffer-read-only from props begend not-pref) + (save-window-excursion + (save-restriction + (when ibegend + (narrow-to-region (car ibegend) + (or (cdr ibegend) + (progn + (goto-char (car ibegend)) + (forward-line 2) + (point)))) + (delete-region (point-min) (point-max)) + (mm-remove-parts handles)) + (setq begend (list (point-marker))) + ;; Do the toggle. + (unless (setq not-pref (cadr (member preferred ihandles))) + (setq not-pref (car ihandles))) + (when (or ibegend + (not (gnus-unbuttonized-mime-type-p + "multipart/alternative"))) + (gnus-add-text-properties + (setq from (point)) + (progn + (insert (format "%d. " id)) + (point)) + `(gnus-callback + (lambda (handles) + (unless ,(not ibegend) + (setq gnus-article-mime-handle-alist + ',gnus-article-mime-handle-alist)) + (gnus-mime-display-alternative + ',ihandles ',not-pref ',begend ,id)) + 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-part ,id + gnus-data ,handle)) + (widget-convert-button 'link from (point) + :action 'gnus-widget-press-button + :button-keymap gnus-widget-button-keymap) + ;; Do the handles + (while (setq handle (pop handles)) + (gnus-add-text-properties + (setq from (point)) + (progn + (insert (format "(%c) %-18s" + (if (equal handle preferred) ?* ? ) + (if (stringp (car handle)) + (car handle) + (car (mm-handle-type handle))))) + (point)) + `(gnus-callback + (lambda (handles) + (unless ,(not ibegend) + (setq gnus-article-mime-handle-alist + ',gnus-article-mime-handle-alist)) + (gnus-mime-display-alternative + ',ihandles ',handle ',begend ,id)) + 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-part ,id + gnus-data ,handle)) + (widget-convert-button 'link from (point) + :action 'gnus-widget-press-button + :button-keymap gnus-widget-button-keymap) + (insert " ")) + (insert "\n\n")) + (when preferred + (if (stringp (car preferred)) + (gnus-display-mime preferred) + (let ((mail-parse-charset gnus-newsgroup-charset)) + (mm-display-part preferred))) + (goto-char (point-max)) + (setcdr begend (point-marker))))) + (when ibegend + (goto-char point)))) + (defun gnus-article-wash-status () "Return a string which display status of article washing." (save-excursion @@ -2140,9 +3126,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." - (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers) - gnus-inhibit-hiding - (gnus-article-hide-headers))) + (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) + (not (save-excursion (set-buffer gnus-summary-buffer) + gnus-have-all-headers))) + (not gnus-inhibit-hiding)) + (gnus-article-hide-headers))) ;;; Article savers. @@ -2283,8 +3271,7 @@ Argument LINES specifies lines to be scrolled down." (defun gnus-article-describe-briefly () "Describe article mode commands briefly." (interactive) - (gnus-message 6 - (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) + (gnus-message 6 (substitute-command-keys "\\\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) (defun gnus-article-summary-command () "Execute the last keystroke in the summary buffer." @@ -2307,9 +3294,15 @@ Argument LINES specifies lines to be scrolled down." (setq func (lookup-key (current-local-map) (this-command-keys))) (call-interactively func))) +(defun gnus-article-check-buffer () + "Beep if not in an article buffer." + (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) "Read a summary buffer key sequence and execute it from the article buffer." (interactive "P") + (gnus-article-check-buffer) (let ((nosaves '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" @@ -2468,15 +3461,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))) @@ -2522,13 +3506,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 @@ -2551,12 +3540,20 @@ 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) +;; Should we be using derived.el for this? (unless gnus-article-edit-mode-map - (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) + (setq gnus-article-edit-mode-map (make-sparse-keymap)) + (set-keymap-parent gnus-article-edit-mode-map text-mode-map) (gnus-define-keys gnus-article-edit-mode-map "\C-c\C-c" gnus-article-edit-done @@ -2608,6 +3605,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) @@ -2616,8 +3615,7 @@ groups." (save-excursion (save-restriction (widen) - (goto-char (point-min)) - (when (search-forward "\n\n" nil 1) + (when (article-goto-body) (let ((lines (count-lines (point) (point-max))) (length (- (point-max) (point))) (case-fold-search t) @@ -2638,11 +3636,25 @@ 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) (let ((buffer-read-only nil)) - (funcall func arg))) + (funcall func arg)) + ;; 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))) + ;; Flush original article as well. + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current)))) (set-buffer buf) (set-window-start (get-buffer-window buf) start) (set-window-point (get-buffer-window buf) (point)))) @@ -2659,25 +3671,12 @@ groups." (insert buf) (let ((winconf gnus-prev-winconf)) (gnus-article-mode) - ;; The cache and backlog have to be flushed somewhat. - (when gnus-use-cache - (gnus-cache-update-article - (car gnus-article-current) (cdr gnus-article-current))) - (when gnus-keep-backlog - (gnus-backlog-remove-article - (car gnus-article-current) (cdr gnus-article-current))) - ;; Flush original article as well. - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) - (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." @@ -2689,6 +3688,88 @@ 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))) + (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 ;;; @@ -2702,9 +3783,9 @@ groups." :type 'regexp) (defcustom gnus-button-alist - `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t - gnus-button-message-id 2) - ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*\\)" 0 t gnus-button-message-id 1) + `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" + 0 t gnus-button-message-id 2) + ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t gnus-button-fetch-group 4) @@ -2712,7 +3793,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) @@ -2945,9 +4026,7 @@ specified by `gnus-button-alist'." 'gnus-callback nil)) (set-marker marker nil))) ;; We skip the headers. - (goto-char (point-min)) - (unless (search-forward "\n\n" nil t) - (goto-char (point-max))) + (article-goto-body) (setq beg (point)) (while (setq entry (pop alist)) (setq regexp (car entry)) @@ -3050,7 +4129,6 @@ specified by `gnus-button-alist'." (defun gnus-button-push (marker) ;; Push button starting at MARKER. (save-excursion - (set-buffer gnus-article-buffer) (goto-char marker) (let* ((entry (gnus-button-entry)) (inhibit-point-motion-hooks t) @@ -3155,26 +4233,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." @@ -3207,7 +4288,7 @@ forbidden in URL encoding." gnus-prev-page-line-format nil `(gnus-prev t local-map ,gnus-prev-page-map gnus-callback gnus-article-button-prev-page - gnus-type annotation)))) + article-type annotation)))) (defvar gnus-next-page-map nil) (unless gnus-next-page-map @@ -3238,7 +4319,7 @@ forbidden in URL encoding." `(gnus-next t local-map ,gnus-next-page-map gnus-callback gnus-article-button-next-page - gnus-type annotation)))) + article-type annotation)))) (defun gnus-article-button-next-page (arg) "Go to the next page." @@ -3256,6 +4337,125 @@ forbidden in URL encoding." (gnus-article-prev-page) (select-window win))) +(defvar gnus-decode-header-methods + '(mail-decode-encoded-word-region) + "List of methods used to decode headers. + +This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is +FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups +whose names match REGEXP. + +For example: +((\"chinese\" . gnus-decode-encoded-word-region-by-guess) + mail-decode-encoded-word-region + (\"chinese\" . rfc1843-decode-region)) +") + +(defvar gnus-decode-header-methods-cache nil) + +(defun gnus-multi-decode-header (start end) + "Apply the functions from `gnus-encoded-word-methods' that match." + (unless (and gnus-decode-header-methods-cache + (eq gnus-newsgroup-name + (car gnus-decode-header-methods-cache))) + (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) + (mapc '(lambda (x) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x)))))) + gnus-decode-header-methods)) + (let ((xlist gnus-decode-header-methods-cache)) + (pop xlist) + (save-restriction + (narrow-to-region start end) + (while xlist + (funcall (pop xlist) (point-min) (point-max)))))) + +;;; +;;; Treatment top-level handling. +;;; + +(defun gnus-treat-article (condition &optional part-number total-parts type) + (let ((length (- (point-max) (point-min))) + (alist gnus-treatment-function-alist) + val elem) + (when (or (not type) + (catch 'found + (let ((list gnus-article-treat-types)) + (while list + (when (string-match (pop list) type) + (throw 'found t)))))) + (while (setq elem (pop alist)) + (setq val (symbol-value (car elem))) + (when (cond + (condition + (eq condition val)) + ((null val) + nil) + ((eq val t) + t) + ((eq val 'head) + nil) + ((eq val 'last) + (eq part-number total-parts)) + ((numberp val) + (< length val)) + (t + (eval val))) + (funcall (cadr elem))))))) + + +;;; @ 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)