X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=cb578a9f4cb980b3d4bf2f07b43bc36f818c45a0;hb=db13061143fa878cd49dcf9ca6278774fc9d09ec;hp=7d43608a367049e1115ea5c41a099734918e4af9;hpb=58450d89a9bb6a0bcd1c278b29433d1a5f86f763;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 7d43608..cb578a9 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -251,7 +251,7 @@ should return the new buffer name." :group 'message-buffers :type '(choice (const :tag "off" nil) (const :tag "unique" unique) - (const :tag "unsuniqueent" unsent) + (const :tag "unsent" unsent) (function fun))) (defcustom message-kill-buffer-on-exit nil @@ -322,7 +322,7 @@ The provided functions are: :group 'message-forwarding :type 'boolean) -(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus" +(defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:" "*All headers that match this regexp will be deleted when resending a message." :group 'message-interface :type 'regexp) @@ -448,6 +448,11 @@ The function `message-setup' runs this hook." :group 'message-various :type 'hook) +(defcustom message-cancel-hook nil + "Hook run when cancelling articles." + :group 'message-various + :type 'hook) + (defcustom message-signature-setup-hook nil "Normal hook, run each time a new outgoing message is initialized. It is run after the headers have been inserted and before @@ -789,6 +794,18 @@ Defaults to `text-mode-abbrev-table'.") "Face used for displaying cited text names." :group 'message-faces) +(defface message-mml-face + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "ForestGreen")) + (t + (:bold t))) + "Face used for displaying MML." + :group 'message-faces) + (defvar message-font-lock-keywords (let* ((cite-prefix "A-Za-z") (cite-suffix (concat cite-prefix "0-9_.@-")) @@ -819,7 +836,9 @@ Defaults to `text-mode-abbrev-table'.") (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" "[:>|}].*") - (0 'message-cited-text-face)))) + (0 'message-cited-text-face)) + ("<#/?\\(multipart\\|part\\|external\\).*>" + (0 'message-mml-face)))) "Additional expressions to highlight in Message mode.") ;; XEmacs does it like this. For Emacs, we have to set the @@ -859,9 +878,21 @@ The cdr of ech entry is a function for applying the face to a region.") (defvar message-send-coding-system 'binary "Coding system to encode outgoing mail.") +(defvar message-draft-coding-system + (cond + ((not (fboundp 'coding-system-p)) nil) + ((coding-system-p 'emacs-mule) 'emacs-mule) + ((coding-system-p 'escape-quoted) 'escape-quoted) + ((coding-system-p 'no-conversion) 'no-conversion) + (t nil)) + "Coding system to compose mail.") + +(defvar message-default-charset 'iso-8859-1 + "Default charset assumed to be used when viewing non-ASCII characters. +This variable is used only in non-Mule Emacsen.") + ;;; Internal variables. -(defvar message-default-charset nil) (defvar message-buffer-list nil) (defvar message-this-is-news nil) (defvar message-this-is-mail nil) @@ -1036,7 +1067,8 @@ The cdr of ech entry is a function for applying the face to a region.") (when value (while (string-match "\n[\t ]+" value) (setq value (replace-match " " t t value))) - value))) + ;; We remove all text props.delete-region + (format "%s" value)))) (defun message-narrow-to-field () "Narrow the buffer to the header on the current line." @@ -1125,9 +1157,21 @@ Return the number of headers removed." (forward-line 1) (if (re-search-forward "^[^ \t]" nil t) (goto-char (match-beginning 0)) - (point-max)))) + (goto-char (point-max))))) number)) +(defun message-remove-first-header (header) + "Remove the first instance of HEADER if there is more than one." + (let ((count 0) + (regexp (concat "^" (regexp-quote header) ":"))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (incf count))) + (while (> count 1) + (message-remove-header header nil t) + (decf count)))) + (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." (widen) @@ -1277,8 +1321,11 @@ 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 "\C-c\C-a" 'message-insert-mime-part) - + (define-key message-mode-map "\C-c\C-a" 'message-mime-attach-file) + (define-key message-mode-map "\C-c\C-m\C-a" 'message-mime-attach-file) + (define-key message-mode-map "\C-c\C-m\C-e" 'message-mime-insert-external) + (define-key message-mode-map "\C-c\C-m\C-q" 'mml-quote-region) + (define-key message-mode-map "\t" 'message-tab)) (easy-menu-define @@ -1812,6 +1859,7 @@ prefix, and don't delete any headers." (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) + (mml-quote-region start end) (goto-char end) (when (re-search-backward "^-- $" start t) ;; Also peel off any blank lines before the signature. @@ -1835,11 +1883,13 @@ prefix, and don't delete any headers." mail-citation-hook) (run-hooks 'mail-citation-hook) (let ((start (point)) + (end (mark t)) (functions (when message-indent-citation-function (if (listp message-indent-citation-function) message-indent-citation-function (list message-indent-citation-function))))) + (mml-quote-region start end) (goto-char start) (while functions (funcall (pop functions))) @@ -1985,7 +2035,8 @@ the user from the mailer." (message-do-fcc) ;;(when (fboundp 'mail-hist-put-headers-into-history) ;; (mail-hist-put-headers-into-history)) - (run-hooks 'message-sent-hook) + (save-excursion + (run-hooks 'message-sent-hook)) (message "Sending...done") ;; Mark the buffer as unmodified and delete auto-save. (set-buffer-modified-p nil) @@ -2228,59 +2279,61 @@ to find out how to use this." message-syntax-checks) message-syntax-checks)) result) - (save-restriction - (message-narrow-to-headers) - ;; Insert some headers. - (message-generate-headers message-required-news-headers) - (mail-encode-encoded-word-buffer) - ;; Let the user do all of the above. - (run-hooks 'message-header-hook)) - (message-cleanup-headers) - (if (not (message-check-news-syntax)) + (if (not (message-check-news-body-syntax)) nil + (save-restriction + (message-narrow-to-headers) + ;; Insert some headers. + (message-generate-headers message-required-news-headers) + (mail-encode-encoded-word-buffer) + ;; Let the user do all of the above. + (run-hooks 'message-header-hook)) (message-encode-message-body) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (buffer-disable-undo) - (erase-buffer) - ;; Avoid copying text props. - (insert (format - "%s" (save-excursion - (set-buffer messbuf) - (buffer-string)))) - ;; Remove some headers. - (save-restriction - (message-narrow-to-headers) + (message-cleanup-headers) + (if (not (message-check-news-syntax)) + nil + (unwind-protect + (save-excursion + (set-buffer tembuf) + (buffer-disable-undo) + (erase-buffer) + ;; Avoid copying text props. + (insert (format + "%s" (save-excursion + (set-buffer messbuf) + (buffer-string)))) ;; Remove some headers. - (message-remove-header message-ignored-news-headers t)) - (goto-char (point-max)) - ;; 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))) - (kill-buffer tembuf)) - (set-buffer messbuf) - (if result - (push 'news message-sent-message-via) - (message "Couldn't send message via news: %s" - (nnheader-get-report (car method))) - nil)))) + (save-restriction + (message-narrow-to-headers) + ;; Remove some headers. + (message-remove-header message-ignored-news-headers t)) + (goto-char (point-max)) + ;; 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))) + (kill-buffer tembuf)) + (set-buffer messbuf) + (if result + (push 'news message-sent-message-via) + (message "Couldn't send message via news: %s" + (nnheader-get-report (car method))) + nil))))) ;;; ;;; Header generation & syntax checking. @@ -2299,14 +2352,11 @@ to find out how to use this." (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-news-header-syntax))) - ;; Check the body. - (message-check-news-body-syntax))))) + ;; We narrow to the headers and check them first. + (save-excursion + (save-restriction + (message-narrow-to-headers) + (message-check-news-header-syntax)))))) (defun message-check-news-header-syntax () (and @@ -3148,10 +3198,6 @@ Headers already prepared in the buffer are not modified." (defun message-buffer-name (type &optional to group) "Return a new (unique) buffer name based on TYPE and TO." (cond - ;; Check whether `message-generate-new-buffers' is a function, - ;; and if so, call it. - ((message-functionp message-generate-new-buffers) - (funcall message-generate-new-buffers type to group)) ;; Generate a new buffer name The Message Way. ((eq message-generate-new-buffers 'unique) (generate-new-buffer-name @@ -3163,6 +3209,10 @@ Headers already prepared in the buffer are not modified." "") (if (and group (not (string= group ""))) (concat " on " group) "") "*"))) + ;; Check whether `message-generate-new-buffers' is a function, + ;; and if so, call it. + ((message-functionp message-generate-new-buffers) + (funcall message-generate-new-buffers type to group)) ((eq message-generate-new-buffers 'unsent) (generate-new-buffer-name (concat "*unsent " type @@ -3286,7 +3336,8 @@ Headers already prepared in the buffer are not modified." (setq buffer-file-name (expand-file-name "*message*" message-auto-save-directory)) (setq buffer-auto-save-file-name (make-auto-save-file-name))) - (clear-visited-file-modtime))) + (clear-visited-file-modtime) + (setq buffer-file-coding-system message-draft-coding-system))) (defun message-disassociate-draft () "Disassociate the message buffer from the drafts directory." @@ -3590,6 +3641,7 @@ responses here are directed to other newsgroups.")) "") mail-header-separator "\n" message-cancel-message) + (run-hooks 'message-cancel-hook) (message "Canceling your article...") (if (let ((message-syntax-checks 'dont-check-for-anything-just-trust-me)) @@ -4077,36 +4129,101 @@ regexp varstr." ;;; MIME functions ;;; -(defun message-insert-mime-part (file type) - "Insert a multipart/alternative part into the buffer." + +;; I really think this function should be renamed. It is only useful +;; for inserting file attachments. + +(defun message-mime-attach-file (file type description) + "Attach a file to the outgoing MIME message. +The file is not inserted or encoded until you send the message with +`\\[message-send-and-exit]' or `\\[message-send]'. + +FILE is the name of the file to attach. TYPE is its content-type, a +string of the form \"type/subtype\". DESCRIPTION is a one-line +description of the attachment." (interactive - (let* ((file (read-file-name "Insert file: " nil nil t)) + (let* ((file (read-file-name "Attach file: " nil nil t)) + (type (completing-read + (format "Content type (default %s): " + (or (mm-default-file-encoding file) + ;; Perhaps here we should check + ;; what the file looks like, and + ;; offer text/plain if it looks + ;; like text/plain. + "application/octet-stream")) + (delete-duplicates + (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) + :test 'equal))) + (description (read-string "One line description: "))) + (list file type description))) + (when (string-match "\\`[ \t]*\\'" description) + (setq description nil)) + (when (string-match "\\`[ \t]*\\'" type) + (setq type (mm-default-file-encoding file))) nil + ;; Prevent some common errors. This is inspired by similar code in + ;; VM. + (when (file-directory-p file) + (error "%s is a directory, cannot attach" file)) + (unless (file-exists-p file) + (error "No such file: %s" file)) + (unless (file-readable-p file) + (error "Permission denied: %s" file)) + (insert (format "<#part type=%s filename=%s%s><#/part>\n" + type (prin1-to-string file) + (if description + (format " description=%s" (prin1-to-string description)) + "")))) + +(defun message-mime-insert-external (file type) + "Insert a message/external-body part into the buffer." + (interactive + (let* ((file (read-file-name "Insert file: ")) (type (mm-default-file-encoding file))) (list file (completing-read (format "MIME type for %s: " file) - (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) + (delete-duplicates + (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions)) nil nil type)))) - (insert (format "\n" + (insert (format "<#external type=%s name=\"%s\"><#/external>\n" type file))) (defun message-encode-message-body () - (message-goto-body) - (narrow-to-region (point) (point-max)) - (let ((new (mml-generate-mime))) - (delete-region (point-min) (point-max)) - (insert new) - (goto-char (point-min)) - (widen) - (forward-line -1) - (let ((beg (point)) - (line (buffer-substring (point) (progn (forward-line 1) (point))))) - (delete-region beg (point)) + (let ((mm-default-charset message-default-charset) + lines multipart-p) + (message-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (let ((new (mml-generate-mime))) + (when new + (delete-region (point-min) (point-max)) + (insert new) + (goto-char (point-min)) + (if (eq (aref new 0) ?\n) + (delete-char 1) + (search-forward "\n\n") + (setq lines (buffer-substring (point-min) (1- (point)))) + (delete-region (point-min) (point)))))) + (save-restriction + (message-narrow-to-headers-or-head) + (message-remove-header "Mime-Version") + (goto-char (point-max)) (insert "Mime-Version: 1.0\n") - (insert line)))) - -(run-hooks 'message-load-hook) + (when lines + (insert lines)) + (setq multipart-p + (re-search-backward "^Content-Type: multipart/" nil t))) + (when multipart-p + (save-restriction + (message-narrow-to-headers-or-head) + (message-remove-first-header "Content-Type") + (message-remove-first-header "Content-Transfer-Encoding")) + (message-goto-body) + (insert "This is a MIME multipart message. If you are reading\n") + (insert "this, you shouldn't.\n")))) (provide 'message) +(run-hooks 'message-load-hook) + ;;; message.el ends here