From 93217a87be65a87c23f0543a300595f0e3515b33 Mon Sep 17 00:00:00 2001 From: ueno Date: Fri, 3 Nov 2000 23:06:56 +0000 Subject: [PATCH] Synch with Gnus. --- lisp/ChangeLog | 74 ++++++++++++++++++++++++ lisp/dgnushack.el | 3 +- lisp/gnus-art.el | 98 ++++++++++++++++++++++++------- lisp/gnus-msg.el | 28 ++++----- lisp/gnus-sum.el | 50 +++++++++++++++- lisp/gnus-uu.el | 2 +- lisp/mail-parse.el | 7 ++- lisp/message.el | 18 +++--- lisp/mm-decode.el | 26 +++++---- lisp/mm-extern.el | 163 ++++++++++++++++++++++++++++++++++++++++++++++++++++ lisp/mm-partial.el | 2 +- lisp/mml.el | 7 ++- lisp/nnwarchive.el | 17 +++--- lisp/rfc2047.el | 2 +- lisp/rfc2231.el | 14 ++++- 15 files changed, 437 insertions(+), 74 deletions(-) create mode 100644 lisp/mm-extern.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0d67469..fe85429 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,77 @@ +2000-11-03 10:46:44 ShengHuo ZHU + + * gnus-msg.el (gnus-msg-mail): Move it backwards. + +2000-11-03 Simon Josefsson + + * rfc2231.el (rfc2231-parse-qp-string): New function. + (require): rfc2047. + + * mail-parse.el (mail-header-parse-content-type): + (mail-header-parse-content-disposition): Support invalid QP + encoded strings, by using `rfc2231-parse-qp-string'. + +2000-11-03 08:58:08 ShengHuo ZHU + + * rfc2231.el (rfc2231-parse-string): Decode when there is no number. + (rfc2231-decode-encoded-string): Typo "> X 1". + (rfc2231-encode-string): Insert the name of charset. + * mail-parse.el (mail-header-encode-parameter): Use RFC2231. + +2000-11-02 23:35:50 ShengHuo ZHU + + * mm-decode.el (mm-save-part): Return the filename. + * gnus-sum.el (gnus-summary-edit-article): Remove a hack. + * gnus-art.el (gnus-mime-save-part-and-strip): New function. + (gnus-mime-action-alist): Use it. + (gnus-mime-button-commands): USe it. + * mm-extern.el (mm-extern-local-file): Error when the file is gone. + (mm-inline-external-body): unwind-protect. + +2000-11-02 21:08:49 ShengHuo ZHU + + * gnus-art.el (gnus-insert-mime-button): Show url. + +2000-11-02 19:51:19 ShengHuo ZHU + + * mml.el (mml-generate-mime-1): Support external url. + * nnwarchive.el (nnwarchive-mail-archive-article): Use external url. + +2000-11-02 16:53:32 ShengHuo ZHU + + * mm-partial.el (mm-inline-partial): Buffer name with a leading space. + * mm-decode.el (mm-display-external): Ditto. + * mm-extern.el: New file. + * mm-decode.el (mm-inline-media-tests): Hook it up. + (mm-inlined-types): Inline message/external-body. + +2000-11-02 Simon Josefsson + + * gnus-art.el (gnus-visible-headers): Add Mail-Followup-To. + + * message.el (message-get-reply-headers): Better handling when + Mail-Followup-To is very large. + +2000-11-02 13:27:56 ShengHuo ZHU + + * gnus-uu.el (gnus-uu-post-news): Comment out the redundancy. + * gnus-art.el (gnus-article-edit-done): + * gnus-sum.el (gnus-summary-edit-article-done): Move line + counting code here. + * gnus-msg.el (gnus-setup-message): Remove a hack. + +2000-11-02 09:33:01 ShengHuo ZHU + + * gnus-sum.el (gnus-newsgroup-variables): New variable. + (gnus-summary-mode): Make them local variables. + (gnus-set-global-variables): Globalize them. + (gnus-summary-exit): Kill them. + +2000-11-02 Hrvoje Niksic + + * rfc2047.el (rfc2047-encoded-word-regexp): Allow empty encoded + word. + 2000-11-01 10:07:13 ShengHuo ZHU * gnus-art.el (gnus-mime-display-part): Add to signed or encrypted. diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el index 95af781..ad5a824 100644 --- a/lisp/dgnushack.el +++ b/lisp/dgnushack.el @@ -207,7 +207,8 @@ Modify to suit your needs.")) (condition-case nil (progn (require 'w3-forms) nil) (error '("nnweb.el" "nnlistserv.el" "nnultimate.el" - "nnslashdot.el" "nnwarchive.el" "webmail.el"))) + "nnslashdot.el" "nnwarchive.el" "webmail.el" + "nnwfm.el"))) (condition-case nil (progn (require 'bbdb) nil) (error '("gnus-bbdb.el"))) diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 158735c..d56b864 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -146,7 +146,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:\\|^[BGF]?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:\\|^Mail-Followup-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." @@ -689,6 +689,7 @@ used." (defcustom gnus-mime-action-alist '(("save to file" . gnus-mime-save-part) + ("save and strip" . gnus-mime-save-part-and-strip) ("display as text" . gnus-mime-inline-part) ("view the part" . gnus-mime-view-part) ("pipe to command" . gnus-mime-pipe-part) @@ -3290,6 +3291,7 @@ value of the variable `gnus-show-mime' is non-nil." (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-view-part-as-type "t" "View As Type...") (gnus-mime-save-part "o" "Save...") + (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") (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") @@ -3343,6 +3345,77 @@ value of the variable `gnus-show-mime' is non-nil." (gnus-mime-view-all-parts (cdr handles)) (mapcar 'mm-display-part handles))))) +(defun gnus-mime-save-part-and-strip () + "Save the MIME part under point then replace it with an external body." + (interactive) + (gnus-article-check-buffer) + (let* ((data (get-text-property (point) 'gnus-data)) + (file (mm-save-part data)) + param) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + (set-buffer gnus-summary-buffer) + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (insert-buffer gnus-original-article-buffer) + (save-restriction + (message-narrow-to-head) + (message-remove-header "Content-Type") + (message-remove-header "MIME-Version") + (message-remove-header "Content-Transfer-Encoding") + (mail-decode-encoded-word-region (point-min) (point-max)) + (goto-char (point-max))) + (forward-char 1) + (delete-region (point) (point-max)) + (setq mml-buffer-list nil) + (if (stringp (car gnus-article-mime-handles)) + (mml-insert-mime gnus-article-mime-handles) + (mml-insert-mime gnus-article-mime-handles t)) + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles nil) + (make-local-hook 'kill-buffer-hook) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight)))))) + (defun gnus-mime-save-part () "Save the MIME part under point." (interactive) @@ -3621,6 +3694,8 @@ In no internal viewer is available, use an external viewer." 'name) (mail-content-type-get (mm-handle-disposition handle) 'filename) + (mail-content-type-get (mm-handle-type handle) + 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description @@ -4493,27 +4568,6 @@ groups." (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (interactive "P") - (save-excursion - (save-restriction - (widen) - (when (article-goto-body) - (let ((lines (count-lines (point) (point-max))) - (length (- (point-max) (point))) - (case-fold-search t) - (body (copy-marker (point)))) - (goto-char (point-min)) - (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward - "^x-content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 33343d6..0f4b95f 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -217,20 +217,6 @@ Thank you for your help in stamping out bugs. ;; "c" gnus-summary-send-draft "r" gnus-summary-resend-message) -;;;###autoload -(defun gnus-msg-mail (&rest args) - "Start editing a mail message to be sent. -Like `message-mail', but with Gnus paraphernalia, particularly the -the Gcc: header for archiving purposes." - (interactive) - (gnus-setup-message 'message - (apply 'message-mail args))) - -;;;###autoload -(define-mail-user-agent 'gnus-user-agent - 'gnus-msg-mail 'message-send-and-exit - 'message-kill-buffer 'message-send-hook) - ;;; Internal functions. (defvar gnus-article-reply nil) @@ -266,6 +252,20 @@ the Gcc: header for archiving purposes." (gnus-configure-windows ,config t) (set-buffer-modified-p nil)))) +;;;###autoload +(defun gnus-msg-mail (&rest args) + "Start editing a mail message to be sent. +Like `message-mail', but with Gnus paraphernalia, particularly the +the Gcc: header for archiving purposes." + (interactive) + (gnus-setup-message 'message + (apply 'message-mail args))) + +;;;###autoload +(define-mail-user-agent 'gnus-user-agent + 'gnus-msg-mail 'message-send-and-exit + 'message-kill-buffer 'message-send-hook) + (defun gnus-setup-posting-charset (group) (let ((alist gnus-group-posting-charset-alist) (group (or group "")) diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index f1b7119..480d0ab 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -1190,6 +1190,9 @@ end position and text.") gnus-newsgroup-incorporated) "Variables that are buffer-local to the summary buffers.") +(defvar gnus-newsgroup-variables nil + "Variables that have separate values in the newsgroups.") + ;; Byte-compiler warning. (defvar gnus-article-mode-map) @@ -2095,6 +2098,8 @@ The following commands are available: (gnus-summary-make-menu-bar)) (kill-all-local-variables) (gnus-summary-make-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-make-local-variables)) (gnus-make-thread-indent-array) (gnus-simplify-mode-line) (setq major-mode 'gnus-summary-mode) @@ -2535,7 +2540,15 @@ buffer that was in action when the last article was fetched." (gac gnus-article-current) (reffed gnus-reffed-article-number) (score-file gnus-current-score-file) - (default-charset gnus-newsgroup-charset)) + (default-charset gnus-newsgroup-charset) + vlist) + (let ((locals gnus-newsgroup-variables)) + (while locals + (if (consp (car locals)) + (push (eval (caar locals)) vlist) + (push (eval (car locals)) vlist)) + (setq locals (cdr locals))) + (setq vlist (nreverse vlist))) (save-excursion (set-buffer gnus-group-buffer) (setq gnus-newsgroup-name name @@ -2550,6 +2563,12 @@ buffer that was in action when the last article was fetched." gnus-reffed-article-number reffed gnus-current-score-file score-file gnus-newsgroup-charset default-charset) + (let ((locals gnus-newsgroup-variables)) + (while locals + (if (consp (car locals)) + (set (caar locals) (pop vlist)) + (set (car locals) (pop vlist))) + (setq locals (cdr locals)))) ;; The article buffer also has local variables. (when (gnus-buffer-live-p gnus-article-buffer) (set-buffer gnus-article-buffer) @@ -5502,12 +5521,16 @@ If FORCE (the prefix), also save the .newsrc file(s)." ;; not garbage-collected, it seems. This would the lead to en ;; ever-growing Emacs. (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) (when (get-buffer gnus-article-buffer) (bury-buffer gnus-article-buffer)) ;; We clear the global counterparts of the buffer-local ;; variables as well, just to be on the safe side. (set-buffer gnus-group-buffer) (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) ;; Return to group mode buffer. (when (eq mode 'gnus-summary-mode) (gnus-kill-buffer buf))) @@ -5551,8 +5574,12 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-deaden-summary) (gnus-close-group group) (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) (set-buffer gnus-group-buffer) (gnus-summary-clear-local-variables) + (let ((gnus-summary-local-variables gnus-newsgroup-variables)) + (gnus-summary-clear-local-variables)) (when (get-buffer gnus-summary-buffer) (kill-buffer gnus-summary-buffer))) (unless gnus-single-article-buffer @@ -8026,10 +8053,31 @@ groups." no-highlight) "Make edits to the current article permanent." (interactive) + (save-excursion + ;; The buffer restriction contains the entire article if it exists. + (when (article-goto-body) + (let ((lines (count-lines (point) (point-max))) + (length (- (point-max) (point))) + (case-fold-search t) + (body (copy-marker (point)))) + (goto-char (point-min)) + (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward + "^x-content-length:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string length))) + (goto-char (point-min)) + (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) + (delete-region (match-beginning 1) (match-end 1)) + (insert (number-to-string lines)))))) ;; Replace the article. (let ((buf (current-buffer))) (with-temp-buffer (insert-buffer-substring buf) + (if (and (not read-only) (not (gnus-request-replace-article (cdr gnus-article-current) (car gnus-article-current) diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el index 74ec1f4..993914b 100644 --- a/lisp/gnus-uu.el +++ b/lisp/gnus-uu.el @@ -1882,7 +1882,7 @@ is t." (let ((map (make-sparse-keymap))) (set-keymap-parent map (current-local-map)) (use-local-map map)) - (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) + ;;(local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done) (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews) (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article) diff --git a/lisp/mail-parse.el b/lisp/mail-parse.el index d0ce7da..95a3359 100644 --- a/lisp/mail-parse.el +++ b/lisp/mail-parse.el @@ -43,10 +43,11 @@ (require 'rfc2047) (require 'rfc2045) -(defalias 'mail-header-parse-content-type 'rfc2231-parse-string) -(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-string) +(defalias 'mail-header-parse-content-type 'rfc2231-parse-qp-string) +(defalias 'mail-header-parse-content-disposition 'rfc2231-parse-qp-string) (defalias 'mail-content-type-get 'rfc2231-get-value) -(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) +;(defalias 'mail-header-encode-parameter 'rfc2045-encode-string) +(defalias 'mail-header-encode-parameter 'rfc2231-encode-string) (defalias 'mail-header-remove-comments 'ietf-drums-remove-comments) (defalias 'mail-header-remove-whitespace 'ietf-drums-remove-whitespace) diff --git a/lisp/message.el b/lisp/message.el index 52f416a..0b9165c 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -4539,15 +4539,17 @@ that further discussion should take place only in " (let (ccalist) (save-excursion (message-set-work-buffer) - (if (and mft - message-use-followup-to - (or (not (eq message-use-followup-to 'ask)) - (message-y-or-n-p - (concat "Obey Mail-Followup-To: " mft "? ") t "\ -You should normally obey the Mail-Followup-To: header. + (if (and mft + message-use-followup-to + (or (not (eq message-use-followup-to 'ask)) + (message-y-or-n-p + (concat "Obey Mail-Followup-To? ") t "\ +You should normally obey the Mail-Followup-To: header. In this +article, it has the value of - `Mail-Followup-To: " mft "' -directs your response to " (if (string-match "," mft) +" mft " + +which directs your response to " (if (string-match "," mft) "the specified addresses" "that address only") ". diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 737eb9d..dba6b1f 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -30,7 +30,8 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'mm-inline-partial "mm-partial")) + (autoload 'mm-inline-partial "mm-partial") + (autoload 'mm-inline-external-body "mm-extern")) (defgroup mime-display () "Display of MIME in mail and news articles." @@ -131,6 +132,7 @@ ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("message/partial" mm-inline-partial identity) + ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) ("audio/wav" mm-inline-audio (lambda (handle) @@ -153,7 +155,7 @@ (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" - "message/partial" "application/emacs-lisp" + "message/partial" "message/external-body" "application/emacs-lisp" "application/pgp-signature") "List of media types that are to be displayed inline." :type '(repeat string) @@ -400,13 +402,13 @@ external if displayed external." (let ((cur (current-buffer))) (if (eq method 'mailcap-save-binary-file) (progn - (set-buffer (generate-new-buffer "*mm*")) + (set-buffer (generate-new-buffer " *mm*")) (setq method nil)) (mm-insert-part handle) (let ((win (get-buffer-window cur t))) (when win (select-window win))) - (switch-to-buffer (generate-new-buffer "*mm*"))) + (switch-to-buffer (generate-new-buffer " *mm*"))) (buffer-disable-undo) (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) @@ -464,7 +466,7 @@ external if displayed external." (progn (call-process shell-file-name nil (setq buffer - (generate-new-buffer "*mm*")) + (generate-new-buffer " *mm*")) nil shell-command-switch (mm-mailcap-command @@ -483,7 +485,7 @@ external if displayed external." (unwind-protect (start-process "*display*" (setq buffer - (generate-new-buffer "*mm*")) + (generate-new-buffer " *mm*")) shell-file-name shell-command-switch (mm-mailcap-command @@ -518,7 +520,7 @@ external if displayed external." (push "<" out) (push (mm-quote-arg file) out))) (mapconcat 'identity (nreverse out) ""))) - + (defun mm-remove-parts (handles) "Remove the displayed MIME parts represented by HANDLES." (if (and (listp handles) @@ -716,10 +718,12 @@ external if displayed external." (or filename name "") (or mm-default-directory default-directory)))) (setq mm-default-directory (file-name-directory file)) - (when (or (not (file-exists-p file)) - (yes-or-no-p (format "File %s already exists; overwrite? " - file))) - (mm-save-part-to-file handle file)))) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (progn + (mm-save-part-to-file handle file) + file)))) (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer diff --git a/lisp/mm-extern.el b/lisp/mm-extern.el new file mode 100644 index 0000000..2fb535b --- /dev/null +++ b/lisp/mm-extern.el @@ -0,0 +1,163 @@ +;;; mm-extern.el --- showing message/external-body +;; Copyright (C) 2000 Free Software Foundation, Inc. + +;; Author: Shenghuo Zhu +;; Keywords: message external-body + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation; either version 2, or (at your +;; option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'mm-util) +(require 'mm-decode) + +(defvar mm-extern-function-alist + '((local-file . mm-extern-local-file) + (url . mm-extern-url) + (anon-ftp . mm-extern-anon-ftp) + (ftp . mm-extern-ftp) +;;; (tftp . mm-extern-tftp) + (mail-server . mm-extern-mail-server) +;;; (afs . mm-extern-afs)) + )) + +(defvar mm-extern-anonymous "anonymous") + +(defun mm-extern-local-file (handle) + (erase-buffer) + (let ((name (cdr (assq 'name (cdr (mm-handle-type handle))))) + (coding-system-for-read mm-binary-coding-system)) + (unless name + (error "The filename is not specified.")) + (mm-disable-multibyte-mule4) + (if (file-exists-p name) + (mm-insert-file-contents name nil nil nil nil t) + (error "The file is gone.")))) + +(defun mm-extern-url (handle) + (erase-buffer) + (require 'url) + (let ((url (cdr (assq 'url (cdr (mm-handle-type handle))))) + (name buffer-file-name) + (coding-system-for-read mm-binary-coding-system)) + (unless url + (error "URL is not specified.")) + (mm-with-unibyte-current-buffer-mule4 + (url-insert-file-contents url)) + (mm-disable-multibyte-mule4) + (setq buffer-file-name name))) + +(defun mm-extern-anon-ftp (handle) + (erase-buffer) + (let* ((params (cdr (mm-handle-type handle))) + (name (cdr (assq 'name params))) + (site (cdr (assq 'site params))) + (directory (cdr (assq 'directory params))) + (mode (cdr (assq 'mode params))) + (path (concat "/" (or mm-extern-anonymous + (read-string (format "ID for %s: " site))) + "@" site ":" directory "/" name)) + (coding-system-for-read mm-binary-coding-system)) + (unless name + (error "The filename is not specified.")) + (mm-disable-multibyte-mule4) + (mm-insert-file-contents path nil nil nil nil t))) + +(defun mm-extern-ftp (handle) + (let (mm-extern-anonymous) + (mm-extern-anon-ftp handle))) + +(defun mm-extern-mail-server (handle) + (require 'message) + (let* ((params (cdr (mm-handle-type handle))) + (server (cdr (assq 'server params))) + (subject (or (cdr (assq 'subject params)) "none")) + (buf (current-buffer)) + info) + (if (y-or-n-p (format "Send a request message to %s?" server)) + (save-window-excursion + (message-mail server subject) + (message-goto-body) + (delete-region (point) (point-max)) + (insert-buffer buf) + (message "Requesting external body...") + (message-send-and-exit) + (setq info "Request is sent.") + (message info)) + (setq info "Request is not sent.")) + (goto-char (point-min)) + (insert "[" info "]\n\n"))) + +;;;###autoload +(defun mm-inline-external-body (handle &optional no-display) + "Show the external-body part of HANDLE. +This function replaces the buffer of HANDLE with a buffer contains +the entire message. +If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." + (let* ((access-type (cdr (assq 'access-type + (cdr (mm-handle-type handle))))) + (func (cdr (assq (intern (downcase access-type)) + mm-extern-function-alist))) + gnus-displaying-mime buf + handles) + (unless (mm-handle-cache handle) + (unless func + (error (format "Access type (%s) is not supported." access-type))) + (with-temp-buffer + (mm-insert-part handle) + (goto-char (point-max)) + (insert "\n\n") + (setq handles (mm-dissect-buffer t))) + (unless (bufferp (car handles)) + (mm-destroy-parts handles) + (error "Multipart external body is not supported.")) + (save-excursion ;; single part + (set-buffer (setq buf (mm-handle-buffer handles))) + (let (good) + (unwind-protect + (progn + (funcall func handle) + (setq good t)) + (unless good + (mm-destroy-parts handles)))) + (mm-handle-set-cache handle handles)) + (push handles gnus-article-mime-handles)) + (unless no-display + (save-excursion + (save-restriction + (narrow-to-region (point) (point)) + (gnus-display-mime (mm-handle-cache handle)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let (buffer-read-only) + (condition-case nil + ;; This is only valid on XEmacs. + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) (current-buffer))) + '(background background-pixmap foreground)) + (error nil)) + (delete-region ,(point-min-marker) ,(point-max-marker)))))))))) + +;; mm-extern.el ends here diff --git a/lisp/mm-partial.el b/lisp/mm-partial.el index 27189c9..734b2a0 100644 --- a/lisp/mm-partial.el +++ b/lisp/mm-partial.el @@ -88,7 +88,7 @@ If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." (list gnus-article-mime-handles)) phandles)) (save-excursion - (set-buffer (generate-new-buffer "*mm*")) + (set-buffer (generate-new-buffer " *mm*")) (while (setq phandle (pop phandles)) (setq nn (string-to-number (cdr (assq 'number diff --git a/lisp/mml.el b/lisp/mml.el index 64ba761..589988c 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -347,7 +347,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (insert "Content-Type: message/external-body") (let ((parameters (mml-parameter-string cont '(expiration size permission))) - (name (cdr (assq 'name cont)))) + (name (cdr (assq 'name cont))) + (url (cdr (assq 'url cont)))) (when name (setq name (mml-parse-file-name name)) (if (stringp name) @@ -365,6 +366,10 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (if (member (nth 0 name) '("ftp@" "anonymous@")) "anon-ftp" "ftp"))))) + (when url + (mml-insert-parameter + (mail-header-encode-parameter "url" url) + "access-type=url")) (when parameters (mml-insert-parameter-string cont '(expiration size permission)))) diff --git a/lisp/nnwarchive.el b/lisp/nnwarchive.el index 5103b55..1a34dde 100644 --- a/lisp/nnwarchive.el +++ b/lisp/nnwarchive.el @@ -696,14 +696,17 @@ (progn (forward-line) (point))) ;; I hate to download the url encode it, then immediately ;; decode it. - ;; FixMe: Find a better solution to attach the URL. - ;; Maybe do some hack in external part of mml-generate-mim-1. - (insert "<#part>" - "\n--\nExternal: \n" - (format "" + (insert "<#external" + " type=" + (or (and url + (string-match "\\.[^\\.]+$" url) + (mailcap-extension-to-mime + (match-string 0 url))) + "application/octet-stream") + (format " url=\"http://www.mail-archive.com/%s/%s\"" group url) - "\n--\n" - "<#/part>") + ">\n" + "<#/external>") (setq mime t)) (t (setq p (point)) diff --git a/lisp/rfc2047.el b/lisp/rfc2047.el index e663384..fa18f9d 100644 --- a/lisp/rfc2047.el +++ b/lisp/rfc2047.el @@ -413,7 +413,7 @@ Should be called narrowed to the head of the message." ;;; (defvar rfc2047-encoded-word-regexp - "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]+\\)\\?=") + "=\\?\\([^][\000-\040()<>@,\;:\\\"/?.=]+\\)\\?\\(B\\|Q\\)\\?\\([!->@-~ +]*\\)\\?=") (defun rfc2047-decode-region (start end) "Decode MIME-encoded words in region between START and END." diff --git a/lisp/rfc2231.el b/lisp/rfc2231.el index d73ae3d..2881706 100644 --- a/lisp/rfc2231.el +++ b/lisp/rfc2231.el @@ -28,11 +28,17 @@ (eval-when-compile (require 'cl)) (require 'ietf-drums) +(require 'rfc2047) (defun rfc2231-get-value (ct attribute) "Return the value of ATTRIBUTE from CT." (cdr (assq attribute (cdr ct)))) +(defun rfc2231-parse-qp-string (string) + "Parse QP-encoded string using `rfc2231-parse-string'. +N.B. This is in violation with RFC2047, but it seem to be in common use." + (rfc2231-parse-string (rfc2047-decode-string string))) + (defun rfc2231-parse-string (string) "Parse STRING and return a list. The list will be on the form @@ -81,7 +87,9 @@ The list will be on the form (when (eq c ?*) (forward-char 1) (setq c (char-after)) - (when (memq c ntoken) + (if (not (memq c ntoken)) + (setq encoded t + number nil) (setq number (string-to-number (buffer-substring @@ -142,7 +150,7 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"." (string-to-number (buffer-substring (point) (+ (point) 2)) 16) (delete-region (1- (point)) (+ (point) 2))))) ;; Encode using the charset, if any. - (when (and (< (length elems) 1) + (when (and (> (length elems) 1) (not (equal (intern (car elems)) 'us-ascii))) (mm-decode-coding-region (point-min) (point-max) (intern (car elems)))) @@ -189,7 +197,7 @@ These look like \"us-ascii'en-us'This%20is%20%2A%2A%2Afun%2A%2A%2A\"." (delete-char 1)) (forward-char 1))) (goto-char (point-min)) - (insert (or charset "ascii") "''") + (insert (or (symbol-name charset) "ascii") "''") (goto-char (point-min)) (if (not broken) (insert param "*=") -- 1.7.10.4