X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=8e9882d4f1f7b0e35f388c77cb11abeb3d88fb8c;hb=778c3b76ebeb9fe66f0987258f52b99887e33515;hp=397210b49c2482b1fc59b3257e0f5e1f52ad44c6;hpb=4af3f74b2f4786e443ed0b9f43b5425943e1b348;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 397210b..82923d6 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -2,7 +2,10 @@ ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen -;; Keywords: mail, news +;; MORIOKA Tomohiko +;; Shuhei KOBAYASHI +;; Keiichi Suzuki +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -29,17 +32,20 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + ) (require 'mailheader) (require 'nnheader) +(require 'timezone) (require 'easymenu) (require 'custom) (if (string-match "XEmacs\\|Lucid" emacs-version) (require 'mail-abbrevs) (require 'mailabbrev)) -(require 'rfc2047) -(require 'mm-bodies) +(require 'mime-edit) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -99,6 +105,10 @@ :group 'message :group 'faces) +(defgroup message-frames nil + "Message frames" + :group 'message) + (defcustom message-directory "~/Mail/" "*Directory from which all other mail file variables are derived." :group 'message-various @@ -123,6 +133,16 @@ mailbox format." (function :tag "Other")) :group 'message-sending) +(defcustom message-encode-function 'message-maybe-encode + "*A function called to encode messages." + :group 'message-sending + :type 'function) + +(defcustom message-8bit-encoding-list '(8bit binary) + "*8bit encoding type in Content-Transfer-Encoding field." + :group 'message-sending + :type '(repeat (symbol :tag "Type"))) + (defcustom message-courtesy-message "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n" "*This is inserted at the start of a mailed copy of a posted message. @@ -137,6 +157,11 @@ If this variable is nil, no such courtesy message will be added." :group 'message-interface :type 'regexp) +(defcustom message-bounce-setup-function 'message-bounce-setup-for-mime-edit + "Function to setup a re-sending bounced message." + :group 'message-sending + :type 'function) + ;;;###autoload (defcustom message-from-style 'default "*Specifies how \"From\" headers look. @@ -218,6 +243,12 @@ any confusion." :group 'message-interface :type 'regexp) +(defcustom message-supersede-setup-function + 'message-supersede-setup-for-mime-edit + "Function to setup a supersede message." + :group 'message-sending + :type 'function) + (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*" "*Regexp matching \"Re: \" in the subject line." :group 'message-various @@ -256,6 +287,15 @@ should return the new buffer name." :group 'message-buffers :type 'boolean) +(defcustom message-kill-buffer-query-function 'yes-or-no-p + "*A function called to query the user whether to kill buffer anyway or not. +If it is t, the buffer will be killed peremptorily." + :type '(radio (function-item yes-or-no-p) + (function-item y-or-n-p) + (function-item nnheader-Y-or-n-p) + (function :tag "Other" t)) + :group 'message-buffers) + (defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) @@ -276,13 +316,13 @@ If t, use `message-user-organization-file'." :group 'message-headers) (defcustom message-forward-start-separator - "------- Start of forwarded message -------\n" + (concat (mime-make-tag "message" "rfc822") "\n") "*Delimiter inserted before forwarded messages." :group 'message-forwarding :type 'string) (defcustom message-forward-end-separator - "------- End of forwarded message -------\n" + (concat (mime-make-tag "text" "plain") "\n") "*Delimiter inserted after forwarded messages." :group 'message-forwarding :type 'string) @@ -293,7 +333,7 @@ If t, use `message-user-organization-file'." :type 'boolean) (defcustom message-included-forward-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^MIME-Version:" "*Regexp matching headers to be included in forwarded messages." :group 'message-forwarding :type 'regexp) @@ -343,16 +383,17 @@ variable `mail-header-separator'. Legal values include `message-send-mail-with-sendmail' (the default), `message-send-mail-with-mh', `message-send-mail-with-qmail' and -`smtpmail-send-it'." +`message-send-mail-with-smtp'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) - (function-item smtpmail-send-it) + (function-item message-send-mail-with-smtp) (function :tag "Other")) :group 'message-sending :group 'message-mail) -(defcustom message-send-news-function 'message-send-news +;; 1997-09-29 by MORIOKA Tomohiko +(defcustom message-send-news-function 'message-send-news-with-gnus "Function to call to send the current buffer as news. The headers should be delimited by a line whose contents match the variable `mail-header-separator'." @@ -439,7 +480,8 @@ variable isn't used." :group 'message-headers :type 'boolean) -(defcustom message-setup-hook nil +(defcustom message-setup-hook + '(message-maybe-setup-default-charset turn-on-mime-edit) "Normal hook, run each time a new outgoing message is initialized. The function `message-setup' runs this hook." :group 'message-various @@ -452,12 +494,24 @@ the signature is inserted." :group 'message-various :type 'hook) +(defcustom message-bounce-setup-hook nil + "Normal hook, run each time a a re-sending bounced message is initialized. +The function `message-bounce' runs this hook." + :group 'message-various + :type 'hook) + +(defcustom message-supersede-setup-hook nil + "Normal hook, run each time a supersede message is initialized. +The function `message-supersede' runs this hook." + :group 'message-various + :type 'hook) + (defcustom message-mode-hook nil "Hook run in message mode buffers." :group 'message-various :type 'hook) -(defcustom message-header-hook nil +(defcustom message-header-hook '(eword-encode-header) "Hook run in a message mode buffer narrowed to the headers." :group 'message-various :type 'hook) @@ -560,6 +614,9 @@ If stringp, use this; if non-nil, use no host name (user name only)." "A list of actions to be performed before killing a message buffer.") (defvar message-postpone-actions nil "A list of actions to be performed after postponing a message.") +(defvar message-original-frame nil) +(defvar message-parameter-alist nil) +(defvar message-startup-parameter-alist nil) (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." @@ -614,6 +671,10 @@ actually occur." :group 'message-sending :type 'sexp) +;;; XXX: This symbol is overloaded! See below. +(defvar message-user-agent nil + "String of the form of PRODUCT/VERSION. Used for User-Agent header field.") + ;; Ignore errors in case this is used in Emacs 19. ;; Don't use ignore-errors because this is copied into loaddefs.el. ;;;###autoload @@ -645,10 +706,10 @@ the prefix.") The default is `abbrev', which uses mailabbrev. nil switches mail aliases off.") -(defcustom message-autosave-directory +(defcustom message-auto-save-directory (nnheader-concat message-directory "drafts/") - "*Directory where Message autosaves buffers if Gnus isn't running. -If nil, Message won't autosave." + "*Directory where Message auto-saves buffers if Gnus isn't running. +If nil, Message won't auto-save." :group 'message-buffers :type 'directory) @@ -844,12 +905,20 @@ The cdr of ech entry is a function for applying the face to a region.") :group 'message-various :type 'hook) -(defvar message-send-coding-system 'binary - "Coding system to encode outgoing mail.") +(defcustom message-use-multi-frames nil + "Make new frame when sending messages." + :group 'message-frames + :type 'boolean) + +(defcustom message-delete-frame-on-exit nil + "Delete frame after sending messages." + :group 'message-frames + :type '(choice (const :tag "off" nil) + (const :tag "always" t) + (const :tag "ask" ask))) ;;; Internal variables. -(defvar message-default-charset nil) (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) @@ -938,7 +1007,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References . message-shorten-references) + (References . message-fill-references) (User-Agent)) "Alist used for formatting headers.") @@ -949,11 +1018,13 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-point-at-eol "gnus-util") (autoload 'gnus-point-at-bol "gnus-util") (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") (autoload 'nndraft-request-expire-articles "nndraft") (autoload 'gnus-open-server "gnus-int") (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") (autoload 'rmail-output "rmail")) @@ -962,6 +1033,22 @@ The cdr of ech entry is a function for applying the face to a region.") ;;; ;;; Utility functions. ;;; +(defun message-eval-parameter (parameter) + (condition-case () + (if (symbolp parameter) + (if (functionp parameter) + (funcall parameter) + (eval parameter)) + parameter) + (error nil))) + +(defsubst message-get-parameter (key &optional alist) + (unless alist + (setq alist message-parameter-alist)) + (cdr (assq key alist))) + +(defmacro message-get-parameter-with-eval (key &optional alist) + `(message-eval-parameter (message-get-parameter ,key ,alist))) (defmacro message-y-or-n-p (question show &rest text) "Ask QUESTION, displaying the rest of the arguments in a temp. buffer if SHOW" @@ -1011,7 +1098,7 @@ The cdr of ech entry is a function for applying the face to a region.") (when (and (file-exists-p file) (file-readable-p file) (file-regular-p file)) - (with-temp-buffer + (nnheader-temp-write nil (nnheader-insert-file-contents file) (goto-char (point-min)) (looking-at message-unix-mail-delimiter)))) @@ -1023,20 +1110,6 @@ The cdr of ech entry is a function for applying the face to a region.") (when value (nnheader-replace-chars-in-string value ?\n ? )))) -(defun message-narrow-to-field () - "Narrow the buffer to the header on the current line." - (beginning-of-line) - (narrow-to-region - (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \n\t]" nil t) - (progn - (beginning-of-line) - (point)) - (point-max)))) - (goto-char (point-min))) - (defun message-add-header (&rest headers) "Add the HEADERS to the message header, skipping those already present." (while headers @@ -1052,11 +1125,12 @@ The cdr of ech entry is a function for applying the face to a region.") (defun message-fetch-reply-field (header) "Fetch FIELD from the message we're replying to." - (when (and message-reply-buffer - (buffer-name message-reply-buffer)) - (save-excursion - (set-buffer message-reply-buffer) - (message-fetch-field header)))) + (let ((buffer (message-eval-parameter message-reply-buffer))) + (when (and buffer + (buffer-name buffer)) + (save-excursion + (set-buffer buffer) + (message-fetch-field header))))) (defun message-set-work-buffer () (if (get-buffer " *message work*") @@ -1065,7 +1139,7 @@ The cdr of ech entry is a function for applying the face to a region.") (erase-buffer)) (set-buffer (get-buffer-create " *message work*")) (kill-all-local-variables) - (mm-enable-multibyte))) + (buffer-disable-undo (current-buffer)))) (defun message-functionp (form) "Return non-nil if FORM is funcallable." @@ -1125,8 +1199,7 @@ Return the number of headers removed." (goto-char (point-min))) (defun message-narrow-to-head () - "Narrow the buffer to the head of the message. -Point is left at the beginning of the narrowed-to region." + "Narrow the buffer to the head of the message." (widen) (narrow-to-region (goto-char (point-min)) @@ -1197,7 +1270,6 @@ Point is left at the beginning of the narrowed-to region." (- max rank) (1+ max))))) (message-sort-headers-1)))) - ;;; @@ -1246,7 +1318,10 @@ Point is left at the beginning of the narrowed-to region." (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature) (define-key message-mode-map "\M-\r" 'message-newline-and-reformat) - (define-key message-mode-map "\t" 'message-tab)) + (define-key message-mode-map "\t" 'message-tab) + + (define-key message-mode-map "\C-x\C-s" 'message-save-drafts) + (define-key message-mode-map "\C-xk" 'message-kill-buffer)) (easy-menu-define message-mode-menu message-mode-map "Message Menu." @@ -1353,13 +1428,15 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq paragraph-separate paragraph-start) (make-local-variable 'message-reply-headers) (setq message-reply-headers nil) - (make-local-variable 'message-newsreader) - (make-local-variable 'message-mailer) + (make-local-variable 'message-user-agent) (make-local-variable 'message-post-method) (make-local-variable 'message-sent-message-via) (setq message-sent-message-via nil) (make-local-variable 'message-checksum) (setq message-checksum nil) + (make-local-variable 'message-parameter-alist) + (setq message-parameter-alist + (copy-sequence message-startup-parameter-alist)) ;;(when (fboundp 'mail-hist-define-keys) ;; (mail-hist-define-keys)) (when (string-match "XEmacs\\|Lucid" emacs-version) @@ -1384,7 +1461,6 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (setq adaptive-fill-first-line-regexp (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-first-line-regexp)) - (mm-enable-multibyte) (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1620,10 +1696,9 @@ text was killed." ;; Then we translate the region. Do it this way to retain ;; text properties. (while (< b e) - (when (< (char-after b) 255) - (subst-char-in-region - b (1+ b) (char-after b) - (aref message-caesar-translation-table (char-after b)))) + (subst-char-in-region + b (1+ b) (char-after b) + (aref message-caesar-translation-table (char-after b))) (incf b)))) (defun message-make-caesar-translation-table (n) @@ -1747,6 +1822,7 @@ However, if `message-yank-prefix' is non-nil, insert that prefix on each line." (forward-line 1)))) (goto-char start))) +(defvar gnus-article-copy) (defun message-yank-original (&optional arg) "Insert the message being replied to, if any. Puts point before the text and mark after. @@ -1758,11 +1834,12 @@ This function uses `message-cite-function' to do the actual citing. Just \\[universal-argument] as argument means don't indent, insert no prefix, and don't delete any headers." (interactive "P") - (let ((modified (buffer-modified-p))) - (when (and message-reply-buffer + (let ((modified (buffer-modified-p)) + (buffer (message-eval-parameter message-reply-buffer))) + (when (and buffer message-cite-function) - (delete-windows-on message-reply-buffer t) - (insert-buffer message-reply-buffer) + (delete-windows-on buffer t) + (insert-buffer buffer) (funcall message-cite-function) (message-exchange-point-and-mark) (unless (bolp) @@ -1876,11 +1953,18 @@ The text will also be indented the normal way." ;;; Sending messages ;;; +;; Avoid byte-compile warning. +(defvar message-encoding-buffer nil) +(defvar message-edit-buffer nil) +(defvar message-mime-mode nil) + (defun message-send-and-exit (&optional arg) "Send message like `message-send', then, if no errors, exit from mail buffer." (interactive "P") (let ((buf (current-buffer)) - (actions message-exit-actions)) + (actions message-exit-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (when (and (message-send arg) (buffer-name buf)) (if message-kill-buffer-on-exit @@ -1889,6 +1973,7 @@ The text will also be indented the normal way." (when (eq buf (current-buffer)) (message-bury buf))) (message-do-actions actions) + (message-delete-frame frame org-frame) t))) (defun message-dont-send () @@ -1896,19 +1981,61 @@ The text will also be indented the normal way." (interactive) (set-buffer-modified-p t) (save-buffer) - (let ((actions message-postpone-actions)) + (let ((actions message-postpone-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (message-bury (current-buffer)) - (message-do-actions actions))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) (defun message-kill-buffer () "Kill the current buffer." (interactive) (when (or (not (buffer-modified-p)) - (yes-or-no-p "Message modified; kill anyway? ")) - (let ((actions message-kill-actions)) + (eq t message-kill-buffer-query-function) + (funcall message-kill-buffer-query-function + "The buffer modified; kill anyway? ")) + (let ((actions message-kill-actions) + (frame (selected-frame)) + (org-frame message-original-frame)) (setq buffer-file-name nil) (kill-buffer (current-buffer)) - (message-do-actions actions)))) + (message-do-actions actions) + (message-delete-frame frame org-frame))) + (message "")) + +(defun message-mimic-kill-buffer () + "Kill the current buffer with query." + (interactive) + (unless (eq 'message-mode major-mode) + (error "%s must be invoked from a message buffer." this-command)) + (let ((command this-command) + (bufname (read-buffer (format "Kill buffer: (default %s) " + (buffer-name))))) + (if (or (not bufname) + (string-equal bufname "") + (string-equal bufname (buffer-name))) + (message-kill-buffer) + (message "%s must be invoked only for the current buffer." command)))) + +(defun message-delete-frame (frame org-frame) + "Delete frame for editing message." + (when (and (or (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + window-system + (>= emacs-major-version 20)) + (or (and (eq message-delete-frame-on-exit t) + (select-frame frame) + (or (eq frame org-frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message "")))) + (and (eq message-delete-frame-on-exit 'ask) + (select-frame frame) + (prog1 + (y-or-n-p "Delete this frame?") + (message ""))))) + (delete-frame frame))) (defun message-bury (buffer) "Bury this mail buffer." @@ -1935,30 +2062,39 @@ the user from the mailer." (undo-boundary) (let ((inhibit-read-only t)) (put-text-property (point-min) (point-max) 'read-only nil)) - (message-fix-before-sending) (run-hooks 'message-send-hook) (message "Sending...") - (let ((alist message-send-method-alist) + (let ((message-encoding-buffer + (message-generate-new-buffer-clone-locals " message encoding")) + (message-edit-buffer (current-buffer)) + (message-mime-mode mime-edit-mode-flag) + (alist message-send-method-alist) (success t) elem sent) - (while (and success - (setq elem (pop alist))) - (when (and (or (not (funcall (cadr elem))) - (and (or (not (memq (car elem) - message-sent-message-via)) - (y-or-n-p - (format - "Already sent message via %s; resend? " - (car elem)))) - (setq success (funcall (caddr elem) arg))))) - (setq sent t))) + (save-excursion + (set-buffer message-encoding-buffer) + (erase-buffer) + (insert-buffer message-edit-buffer) + (funcall message-encode-function) + (message-fix-before-sending) + (while (and success + (setq elem (pop alist))) + (when (and (or (not (funcall (cadr elem))) + (and (or (not (memq (car elem) + message-sent-message-via)) + (y-or-n-p + (format + "Already sent message via %s; resend? " + (car elem)))) + (setq success (funcall (caddr elem) arg))))) + (setq sent t)))) (when (and success sent) (message-do-fcc) ;;(when (fboundp 'mail-hist-put-headers-into-history) ;; (mail-hist-put-headers-into-history)) (run-hooks 'message-sent-hook) (message "Sending...done") - ;; Mark the buffer as unmodified and delete autosave. + ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) (delete-auto-save-file-if-necessary t) (message-disassociate-draft) @@ -1974,7 +2110,7 @@ the user from the mailer." (defun message-send-via-news (arg) "Send the current message via news." - (funcall message-send-news-function arg)) + (message-send-news arg)) (defun message-fix-before-sending () "Do various things to make the message nice before sending it." @@ -1982,11 +2118,12 @@ the user from the mailer." (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. - (when (text-property-any (point-min) (point-max) 'invisible t) - (put-text-property (point-min) (point-max) 'invisible nil) - (unless (yes-or-no-p "Invisible text found and made visible; continue posting?") - (error "Invisible text found and made visible")))) + ;; Make all invisible text visible. + ;;(when (text-property-any (point-min) (point-max) 'invisible t) + ;; (put-text-property (point-min) (point-max) 'invisible nil) + ;; (unless (yes-or-no-p "Invisible text found and made visible; continue posting?") + ;; (error "Invisible text found and made visible"))) + ) (defun message-add-action (action &rest types) "Add ACTION to be performed when doing an exit of type TYPES." @@ -2013,44 +2150,47 @@ the user from the mailer." (require 'mail-utils) (let ((tembuf (message-generate-new-buffer-clone-locals " message temp")) (case-fold-search nil) - (news (message-news-p)) - (mailbuf (current-buffer))) + (news (message-news-p))) (save-restriction (message-narrow-to-headers) ;; Insert some headers. (let ((message-deletable-headers (if news nil message-deletable-headers))) (message-generate-headers message-required-mail-headers)) - (rfc2047-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (message-encode-message-body) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer mailbuf) - (buffer-string)))) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) + (if (not (message-check-mail-syntax)) + (progn + (message "") + ;;(message "Posting not performed") + nil) + (unwind-protect + (save-excursion + (set-buffer tembuf) + (erase-buffer) + (insert-buffer message-encoding-buffer) ;; Remove some headers. - (message-remove-header message-ignored-mail-headers t)) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - (when (and news - (or (message-fetch-field "cc") - (message-fetch-field "to"))) - (message-insert-courtesy-copy)) - (funcall message-send-mail-function)) - (kill-buffer tembuf)) - (set-buffer mailbuf) - (push 'mail message-sent-message-via))) + (save-restriction + (message-narrow-to-headers) + (message-remove-header message-ignored-mail-headers t)) + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + (when (and news + (or (message-fetch-field "cc") + (message-fetch-field "to"))) + (message-insert-courtesy-copy)) + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (funcall message-send-mail-function) + ))) + (funcall message-send-mail-function)) + (kill-buffer tembuf)) + (set-buffer message-edit-buffer) + (push 'mail message-sent-message-via)))) (defun message-send-mail-with-sendmail () "Send off the prepared buffer with sendmail." @@ -2079,31 +2219,31 @@ the user from the mailer." (save-excursion (set-buffer errbuf) (erase-buffer)))) - (let ((default-directory "/") - (coding-system-for-write message-send-coding-system)) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - ;; But some systems are more broken with -f, so - ;; we'll let users override this. - (if (null message-sendmail-f-is-evil) - (list "-f" (user-login-name))) - ;; These mean "report errors by mail" - ;; and "deliver in background". - (if (null message-interactive) '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (if resend-to-addresses - (list resend-to-addresses) - '("-t"))))) + (let ((default-directory "/")) + (as-binary-process + (apply 'call-process-region + (append (list (point-min) (point-max) + (if (boundp 'sendmail-program) + sendmail-program + "/usr/lib/sendmail") + nil errbuf nil "-oi") + ;; Always specify who from, + ;; since some systems have broken sendmails. + ;; But some systems are more broken with -f, so + ;; we'll let users override this. + (if (null message-sendmail-f-is-evil) + (list "-f" (user-login-name))) + ;; These mean "report errors by mail" + ;; and "deliver in background". + (if (null message-interactive) '("-oem" "-odb")) + ;; Get the addresses from the message + ;; unless this is a resend. + ;; We must not do that for a resend + ;; because we would find the original addresses. + ;; For a resend, include the specific addresses. + (if resend-to-addresses + (list resend-to-addresses) + '("-t")))))) (when message-interactive (save-excursion (set-buffer errbuf) @@ -2128,28 +2268,28 @@ to find out how to use this." (run-hooks 'message-send-mail-hook) ;; send the message (case - (let ((coding-system-for-write message-send-coding-system)) - (apply - 'call-process-region 1 (point-max) message-qmail-inject-program - nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the - ;; command line; if there're none, it scans the headers. - ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. - ;; - ;; in general, ALL of qmail-inject's defaults are perfect for simply - ;; reading a formatted (i. e., at least a To: or Resent-To header) - ;; message from stdin. - ;; - ;; qmail also has the advantage of not having been raped by - ;; various vendors, so we don't have to allow for that, either -- - ;; compare this with message-send-mail-with-sendmail and weep - ;; for sendmail's lost innocence. - ;; - ;; all this is way cool coz it lets us keep the arguments entirely - ;; free for -inject-arguments -- a big win for the user and for us - ;; since we don't have to play that double-guessing game and the user - ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args)) + (as-binary-process + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args)) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -2176,13 +2316,151 @@ to find out how to use this." ;; Pass it on to mh. (mh-send-letter))) +(defun message-send-mail-with-smtp () + "Send the prepared message buffer with SMTP." + (require 'smtp) + (let ((errbuf (if mail-interactive + (generate-new-buffer " smtp errors") + 0)) + (case-fold-search nil) + resend-to-addresses + delimline) + (unwind-protect + (save-excursion + (goto-char (point-max)) + ;; require one newline at the end. + (or (= (preceding-char) ?\n) + (insert ?\n)) + ;; Change header-delimiter to be what sendmail expects. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (setq delimline (point-marker)) + (run-hooks 'message-send-mail-hook) + ;; (sendmail-synch-aliases) + ;; (if mail-aliases + ;; (expand-mail-aliases (point-min) delimline)) + (goto-char (point-min)) + ;; ignore any blank lines in the header + (while (and (re-search-forward "\n\n\n*" delimline t) + (< (point) delimline)) + (replace-match "\n")) + (let ((case-fold-search t)) + (goto-char (point-min)) + (goto-char (point-min)) + (while (re-search-forward "^Resent-to:" delimline t) + (setq resend-to-addresses + (save-restriction + (narrow-to-region (point) + (save-excursion + (end-of-line) + (point))) + (append (mail-parse-comma-list) + resend-to-addresses)))) +;;; Apparently this causes a duplicate Sender. +;;; ;; If the From is different than current user, insert Sender. +;;; (goto-char (point-min)) +;;; (and (re-search-forward "^From:" delimline t) +;;; (progn +;;; (require 'mail-utils) +;;; (not (string-equal +;;; (mail-strip-quoted-names +;;; (save-restriction +;;; (narrow-to-region (point-min) delimline) +;;; (mail-fetch-field "From"))) +;;; (user-login-name)))) +;;; (progn +;;; (forward-line 1) +;;; (insert "Sender: " (user-login-name) "\n"))) + ;; Don't send out a blank subject line + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]*\n" delimline t) + (replace-match "")) + ;; Put the "From:" field in unless for some odd reason + ;; they put one in themselves. + (goto-char (point-min)) + (if (not (re-search-forward "^From:" delimline t)) + (let* ((login user-mail-address) + (fullname (user-full-name))) + (cond ((eq mail-from-style 'angles) + (insert "From: " fullname) + (let ((fullname-start (+ (point-min) 6)) + (fullname-end (point-marker))) + (goto-char fullname-start) + ;; Look for a character that cannot appear unquoted + ;; according to RFC 822. + (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" + fullname-end 1) + (progn + ;; Quote fullname, escaping specials. + (goto-char fullname-start) + (insert "\"") + (while (re-search-forward "[\"\\]" + fullname-end 1) + (replace-match "\\\\\\&" t)) + (insert "\"")))) + (insert " <" login ">\n")) + ((eq mail-from-style 'parens) + (insert "From: " login " (") + (let ((fullname-start (point))) + (insert fullname) + (let ((fullname-end (point-marker))) + (goto-char fullname-start) + ;; RFC 822 says \ and nonmatching parentheses + ;; must be escaped in comments. + ;; Escape every instance of ()\ ... + (while (re-search-forward "[()\\]" fullname-end 1) + (replace-match "\\\\\\&" t)) + ;; ... then undo escaping of matching parentheses, + ;; including matching nested parentheses. + (goto-char fullname-start) + (while (re-search-forward + "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" + fullname-end 1) + (replace-match "\\1(\\3)" t) + (goto-char fullname-start)))) + (insert ")\n")) + ((null mail-from-style) + (insert "From: " login "\n"))))) + ;; Insert an extra newline if we need it to work around + ;; Sun's bug that swallows newlines. + (goto-char (1+ delimline)) + (if (eval mail-mailer-swallows-blank-line) + (newline)) + ;; Find and handle any FCC fields. + (goto-char (point-min)) + (if (re-search-forward "^FCC:" delimline t) + (mail-do-fcc delimline)) + (if mail-interactive + (save-excursion + (set-buffer errbuf) + (erase-buffer)))) + ;; + ;; + ;; + (let ((recipient-address-list + (or resend-to-addresses + (smtp-deduce-address-list (current-buffer) + (point-min) delimline)))) + (smtp-do-bcc delimline) + + (if recipient-address-list + (if (not (smtp-via-smtp recipient-address-list + (current-buffer))) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")) + )) + (if (bufferp errbuf) + (kill-buffer errbuf))))) + (defun message-send-news (&optional arg) (let ((tembuf (message-generate-new-buffer-clone-locals " *message temp*")) (case-fold-search nil) (method (if (message-functionp message-post-method) (funcall message-post-method arg) message-post-method)) - (messbuf (current-buffer)) (message-syntax-checks (if arg (cons '(existing-newsgroups . disabled) @@ -2193,10 +2471,8 @@ to find out how to use this." (message-narrow-to-headers) ;; Insert some headers. (message-generate-headers message-required-news-headers) - (rfc2047-encode-message-header) ;; Let the user do all of the above. (run-hooks 'message-header-hook)) - (message-encode-message-body) (message-cleanup-headers) (if (not (message-check-news-syntax)) (progn @@ -2207,11 +2483,7 @@ to find out how to use this." (set-buffer tembuf) (buffer-disable-undo (current-buffer)) (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) + (insert-buffer message-encoding-buffer) ;; Remove some headers. (save-restriction (message-narrow-to-headers) @@ -2221,30 +2493,48 @@ to find out how to use this." ;; require one newline at the end. (or (= (preceding-char) ?\n) (insert ?\n)) - (let ((case-fold-search t)) - ;; Remove the delimiter. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1)) - (run-hooks 'message-send-news-hook) - ;;(require (car method)) - ;;(funcall (intern (format "%s-open-server" (car method))) - ;;(cadr method) (cddr method)) - ;;(setq result - ;; (funcall (intern (format "%s-request-post" (car method))) - ;; (cadr method))) - (gnus-open-server method) - (setq result (gnus-request-post method))) + (mime-edit-maybe-split-and-send + (function + (lambda () + (interactive) + (save-restriction + (std11-narrow-to-header mail-header-separator) + (goto-char (point-min)) + (when (re-search-forward "^Message-Id:" nil t) + (delete-region (match-end 0)(std11-field-end)) + (insert (concat " " (message-make-message-id))) + )) + (funcall message-send-news-function method) + ))) + (setq result (funcall message-send-news-function method))) (kill-buffer tembuf)) - (set-buffer messbuf) + (set-buffer message-edit-buffer) (if result (push 'news message-sent-message-via) (message "Couldn't send message via news: %s" (nnheader-get-report (car method))) nil)))) +;; 1997-09-29 by MORIOKA Tomohiko +(defun message-send-news-with-gnus (method) + (let ((case-fold-search t)) + ;; Remove the delimiter. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + (backward-char 1) + (run-hooks 'message-send-news-hook) + ;;(require (car method)) + ;;(funcall (intern (format "%s-open-server" (car method))) + ;;(cadr method) (cddr method)) + ;;(setq result + ;; (funcall (intern (format "%s-request-post" (car method))) + ;; (cadr method))) + (gnus-open-server method) + (gnus-request-post method) + )) + ;;; ;;; Header generation & syntax checking. ;;; @@ -2278,7 +2568,9 @@ to find out how to use this." (message-narrow-to-headers) (message-check-news-header-syntax))) ;; Check the body. - (message-check-news-body-syntax))))) + (save-excursion + (set-buffer message-edit-buffer) + (message-check-news-body-syntax)))))) (defun message-check-news-header-syntax () (and @@ -2490,10 +2782,13 @@ to find out how to use this." (y-or-n-p "Empty article. Really post? ")))) ;; Check for control characters. (message-check 'control-chars - (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t) + (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t) (y-or-n-p "The article contains control characters. Really post? ") t)) + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit)) ;; Check excessive size. (message-check 'size (if (> (buffer-size) 60000) @@ -2521,6 +2816,54 @@ to find out how to use this." (1- (count-lines (point) (point-max))))) t))))) +(defun message-check-mail-syntax () + "Check the syntax of the message." + (save-excursion + (save-restriction + (widen) + (and + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-mail-header-syntax))) + ;; Check the body. + (save-excursion + (set-buffer message-edit-buffer) + (message-check-mail-body-syntax)))))) + +(defun message-check-mail-header-syntax () + t) + +(defun message-check-mail-body-syntax () + (and + ;; Check 8bit characters. + (message-check '8bit + (message-check-8bit) + ))) + +(defun message-check-8bit () + "Check the article contains 8bit characters." + (save-excursion + (set-buffer message-encoding-buffer) + (message-narrow-to-headers) + (let* ((case-fold-search t) + (field-value (message-fetch-field "content-transfer-encoding"))) + (if (and field-value + (member (downcase field-value) message-8bit-encoding-list)) + t + (widen) + (set-buffer (get-buffer-create " message syntax")) + (erase-buffer) + (goto-char (point-min)) + (set-buffer-multibyte nil) + (insert-buffer message-encoding-buffer) + (goto-char (point-min)) + (if (re-search-forward "[^\x00-\x7f]" nil t) + (y-or-n-p + "The article contains 8bit characters. Really post? ") + t))))) + (defun message-checksum () "Return a \"checksum\" for the current buffer." (let ((sum 0)) @@ -2538,13 +2881,13 @@ to find out how to use this." (defun message-do-fcc () "Process Fcc headers in the current buffer." (let ((case-fold-search t) - (buf (current-buffer)) + (coding-system-for-write 'raw-text) list file) (save-excursion (set-buffer (get-buffer-create " *message temp*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (insert-buffer-substring buf) + (insert-buffer-substring message-encoding-buffer) (save-restriction (message-narrow-to-headers) (while (setq file (message-fetch-field "fcc")) @@ -2579,7 +2922,7 @@ to find out how to use this." "Append this article to Unix/babyl mail file.." (if (and (file-readable-p filename) (mail-file-babyl-p filename)) - (rmail-output-to-rmail-file filename t) + (gnus-output-to-rmail filename t) (gnus-output-to-mail filename t))) (defun message-cleanup-headers () @@ -2614,20 +2957,11 @@ to find out how to use this." (when (re-search-forward ",+$" nil t) (replace-match "" t t)))))) -(defun message-make-date (&optional now) - "Make a valid data header. -If NOW, use that time instead." - (let* ((now (or now (current-time))) - (zone (nth 8 (decode-time now))) - (sign "+")) - ;; We do all of this because XEmacs doesn't have the %z spec. - (when (> (/ zone 3600) 12) - (setq sign "-" - zone (- zone (* 3600 12)))) - (concat (format-time-string "%d %b %Y %H:%M:%S " (or now (current-time))) - (format "%s%02d%02d" - sign (/ zone 3600) - (% zone 3600))))) +(defun message-make-date () + "Make a valid data header." + (let ((now (current-time))) + (timezone-make-date-arpa-standard + (current-time-string now) (current-time-zone now)))) (defun message-make-message-id () "Make a unique Message-ID." @@ -2726,17 +3060,21 @@ If NOW, use that time instead." "Return the In-Reply-To header for this message." (when message-reply-headers (let ((from (mail-header-from message-reply-headers)) - (date (mail-header-date message-reply-headers))) - (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) - "'s message of \"" - (if (or (not date) (string= date "")) - "(unknown date)" date) - "\"")))))) + (date (mail-header-date message-reply-headers)) + (msg-id (mail-header-message-id message-reply-headers))) + (when msg-id + (concat msg-id + (when from + (let ((stop-pos + (string-match " *at \\| *@ \\| *(\\| *<" from))) + (concat " (" + (if (and stop-pos + (not (zerop stop-pos))) + (substring from 0 stop-pos) from) + "'s message of \"" + (if (or (not date) (string= date "")) + "(unknown date)" date) + "\")")))))))) (defun message-make-distribution () "Make a Distribution header." @@ -2752,7 +3090,9 @@ If NOW, use that time instead." ;; Add the future to current. (setcar current (+ (car current) (round (/ future (expt 2 16))))) (setcar (cdr current) (+ (nth 1 current) (% (round future) (expt 2 16)))) - (message-make-date current))) + ;; Return the date in the future in UT. + (timezone-make-date-arpa-standard + (current-time-string current) (current-time-zone current) '(0 "UT")))) (defun message-make-path () "Return uucp path." @@ -2874,6 +3214,24 @@ give as trustworthy answer as possible." (or mail-host-address (message-make-fqdn))) +(defun message-make-user-agent () + "Return user-agent info." + (if message-user-agent + (save-excursion + (goto-char (point-min)) + (let ((case-fold-search t) + user-agent beg p end) + (if (re-search-forward "^User-Agent:[ \t]*" nil t) + (progn + (setq beg (match-beginning 0) + p (match-end 0) + end (std11-field-end) + user-agent (buffer-substring p end)) + (delete-region beg (1+ end)) + (concat message-user-agent " " user-agent) + ) + message-user-agent))))) + (defun message-generate-headers (headers) "Prepare article HEADERS. Headers already prepared in the buffer are not modified." @@ -2890,7 +3248,7 @@ Headers already prepared in the buffer are not modified." (To nil) (Distribution (message-make-distribution)) (Lines (message-make-lines)) - (User-Agent message-newsreader) + (User-Agent (message-make-user-agent)) (Expires (message-make-expires)) (case-fold-search t) header value elem) @@ -3056,6 +3414,13 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) (fill-column 990) @@ -3082,7 +3447,7 @@ Headers already prepared in the buffer are not modified." (let ((max 988) (cut 4) refs) - (with-temp-buffer + (nnheader-temp-write nil (insert references) (goto-char (point-min)) (while (re-search-forward "<[^>]+>" nil t) @@ -3138,7 +3503,24 @@ Headers already prepared in the buffer are not modified." (defun message-pop-to-buffer (name) "Pop to buffer NAME, and warn if it already exists and is modified." - (let ((buffer (get-buffer name))) + (let ((pop-up-frames pop-up-frames) + (special-display-buffer-names special-display-buffer-names) + (special-display-regexps special-display-regexps) + (same-window-buffer-names same-window-buffer-names) + (same-window-regexps same-window-regexps) + (buffer (get-buffer name)) + (cur (current-buffer))) + (if (or (and (featurep 'xemacs) + (not (eq 'tty (device-type)))) + window-system + (>= emacs-major-version 20)) + (when message-use-multi-frames + (setq pop-up-frames t + special-display-buffer-names nil + special-display-regexps nil + same-window-buffer-names nil + same-window-regexps nil)) + (setq pop-up-frames nil)) (if (and buffer (buffer-name buffer)) (progn @@ -3149,7 +3531,10 @@ Headers already prepared in the buffer are not modified." (error "Message being composed"))) (set-buffer (pop-to-buffer name))) (erase-buffer) - (message-mode))) + (message-mode) + (when pop-up-frames + (make-local-variable 'message-original-frame) + (setq message-original-frame (selected-frame))))) (defun message-do-send-housekeeping () "Kill old message buffers." @@ -3184,7 +3569,9 @@ Headers already prepared in the buffer are not modified." mc-modes-alist)) (when actions (setq message-send-actions actions)) - (setq message-reply-buffer replybuffer) + (setq message-reply-buffer + (or (message-get-parameter 'reply-buffer) + replybuffer)) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format @@ -3238,12 +3625,12 @@ Headers already prepared in the buffer are not modified." (defun message-set-auto-save-file-name () "Associate the message buffer with a file in the drafts directory." - (when message-autosave-directory + (when message-auto-save-directory (if (gnus-alive-p) (setq message-draft-article (nndraft-request-associate-buffer "drafts")) (setq buffer-file-name (expand-file-name "*message*" - message-autosave-directory)) + message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) (clear-visited-file-modtime))) @@ -3524,14 +3911,14 @@ responses here are directed to other newsgroups.")) message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. - (unless (or (and sender - (string-equal - (downcase sender) - (downcase (message-make-sender)))) - (string-equal - (downcase (cadr (mail-extract-address-components from))) - (downcase (cadr (mail-extract-address-components - (message-make-from)))))) + (unless (or (and sender + (string-equal + (downcase sender) + (downcase (message-make-sender)))) + (string-equal + (downcase (cadr (mail-extract-address-components from))) + (downcase (cadr (mail-extract-address-components + (message-make-from)))))) (error "This article is not yours")) ;; Make control message. (setq buf (set-buffer (get-buffer-create " *message cancel*"))) @@ -3548,11 +3935,17 @@ responses here are directed to other newsgroups.")) message-cancel-message) (message "Canceling your article...") (if (let ((message-syntax-checks - 'dont-check-for-anything-just-trust-me)) - (funcall message-send-news-function)) + 'dont-check-for-anything-just-trust-me) + (message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-news)) (message "Canceling your article...done")) (kill-buffer buf))))) +(defun message-supersede-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-supersede () "Start composing a message to supersede the current message. @@ -3586,7 +3979,11 @@ header line with the old Message-ID." (goto-char (point-max)) (insert mail-header-separator) (widen) - (forward-line 1))) + (when message-supersede-setup-function + (funcall message-supersede-setup-function)) + (run-hooks 'message-supersede-setup-hook) + (goto-char (point-min)) + (search-forward (concat "\n" mail-header-separator "\n") nil t))) ;;;###autoload (defun message-recover () @@ -3610,7 +4007,7 @@ header line with the old Message-ID." (defun message-wash-subject (subject) "Remove junk like \"Re:\", \"(fwd)\", etc. that was added to the subject by previous forwarders, replyers, etc." - (with-temp-buffer + (nnheader-temp-write nil (insert-string subject) (goto-char (point-min)) ;; strip Re/Fwd stuff off the beginning @@ -3666,8 +4063,10 @@ the message." (let ((funcs message-make-forward-subject-function) (subject (if message-wash-forwarded-subjects (message-wash-subject - (or (message-fetch-field "Subject") "")) - (or (message-fetch-field "Subject") "")))) + (or (eword-decode-unstructured-field-body + (message-fetch-field "Subject")) "")) + (or (eword-decode-unstructured-field-body + (message-fetch-field "Subject")) "")))) ;; Make sure funcs is a list. (and funcs (not (listp funcs)) @@ -3728,7 +4127,10 @@ Optional NEWS will use news to forward instead of mail." (set-buffer (get-buffer-create " *message resend*")) (buffer-disable-undo (current-buffer)) (erase-buffer) - (message-setup `((To . ,address))) + ;; avoid to turn-on-mime-edit + (let (message-setup-hook) + (message-setup `((To . ,address))) + ) ;; Insert our usual headers. (message-generate-headers '(From Date To)) (message-narrow-to-headers) @@ -3759,10 +4161,16 @@ Optional NEWS will use news to forward instead of mail." (when (looking-at "From ") (replace-match "X-From-Line: ")) ;; Send it. - (message-send-mail) + (let ((message-encoding-buffer (current-buffer)) + (message-edit-buffer (current-buffer))) + (message-send-mail)) (kill-buffer (current-buffer))) (message "Resending message to %s...done" address))) +(defun message-bounce-setup-for-mime-edit () + (set (make-local-variable 'message-setup-hook) nil) + (mime-edit-again)) + ;;;###autoload (defun message-bounce () "Re-mail the current message. @@ -3776,7 +4184,7 @@ you." (insert-buffer-substring cur) (undo-boundary) (message-narrow-to-head) - (if (and (message-fetch-field "Mime-Version") + (if (and (message-fetch-field "MIME-Version") (setq boundary (message-fetch-field "Content-Type"))) (if (string-match "boundary=\"\\([^\"]+\\)\"" boundary) (setq boundary (concat (match-string 1 boundary) " *\n" @@ -3802,6 +4210,9 @@ you." (message-remove-header message-ignored-bounced-headers t) (goto-char (point-max)) (insert mail-header-separator)) + (when message-bounce-setup-function + (funcall message-bounce-setup-function)) + (run-hooks 'message-bounce-setup-hook) (message-position-point))) ;;; @@ -4003,7 +4414,7 @@ regexp varstr." (let ((locals (save-excursion (set-buffer buffer) (buffer-local-variables))) - (regexp "^gnus\\|^nn\\|^message")) + (regexp "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)")) (mapcar (lambda (local) (when (and (consp local) @@ -4014,6 +4425,47 @@ regexp varstr." (cdr local))))) locals))) +;;; @ for MIME Edit mode +;;; + +(defun message-maybe-setup-default-charset () + (let ((charset + (and (boundp 'gnus-summary-buffer) + (buffer-live-p gnus-summary-buffer) + (save-excursion + (set-buffer gnus-summary-buffer) + default-mime-charset)))) + (if charset + (progn + (make-local-variable 'default-mime-charset) + (setq default-mime-charset charset) + )))) + +(defun message-maybe-encode () + (when message-mime-mode + (run-hooks 'mime-edit-translate-hook) + (if (catch 'mime-edit-error + (save-excursion + (mime-edit-translate-body) + )) + (error "Translation error!") + ) + (end-of-invisible) + (run-hooks 'mime-edit-exit-hook) + )) + +(defun message-mime-insert-article (&optional message) + (interactive) + (let ((message-cite-function 'mime-edit-inserted-message-filter) + (message-reply-buffer + (message-get-parameter-with-eval 'original-buffer)) + (start (point))) + (message-yank-original nil) + )) + +(set-alist 'mime-edit-message-inserter-alist + 'message-mode (function message-mime-insert-article)) + ;;; Miscellaneous functions ;; stolen (and renamed) from nnheader.el @@ -4029,34 +4481,20 @@ regexp varstr." (setq idx (1+ idx))) string)) -;;; -;;; MIME functions -;;; - -(defun message-encode-message-body () - "Examine the message body, encode it, and add the requisite headers." - (when (featurep 'mule) - (save-excursion - (save-restriction - (message-narrow-to-headers) - (message-remove-header - "^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:" t) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (let* ((charset (mm-encode-body)) - (encoding (mm-body-encoding))) - (when (consp charset) - (error "Can't encode messages with multiple charsets (yet)")) - (widen) - (message-narrow-to-headers) - (goto-char (point-max)) - (setq charset (or charset (mm-mule-charset-to-mime-charset 'ascii))) - ;; We don't insert MIME headers if they only say the default. - (unless (and (eq charset 'ascii) - (eq encoding '7bit)) - (mm-insert-rfc822-headers charset encoding)) - (mm-encode-body)))))) +(defvar message-save-buffer " *encoding") +(defun message-save-drafts () + (interactive) + (if (not (get-buffer message-save-buffer)) + (get-buffer-create message-save-buffer)) + (let ((filename buffer-file-name) + (buffer (current-buffer))) + (set-buffer message-save-buffer) + (erase-buffer) + (insert-buffer buffer) + (mime-edit-translate-buffer) + (write-region (point-min) (point-max) filename) + (set-buffer buffer) + (set-buffer-modified-p nil))) (run-hooks 'message-load-hook)