X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=1b43f68f7d46807c4e3430ddf17532557b93b07b;hb=e405b22c6b46721607c5e6c712a4705c23dee751;hp=af9b23cd0ae91fa6e637adad0202a911a78068a4;hpb=c3f257c7a905d31b86dd75fceb61a376cf4afe87;p=gnus diff --git a/lisp/mml.el b/lisp/mml.el index af9b23cd0..1b43f68f7 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -1,5 +1,6 @@ ;;; mml.el --- A package for parsing and validating MML documents -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -33,14 +34,18 @@ (eval-and-compile (autoload 'message-make-message-id "message") (autoload 'gnus-setup-posting-charset "gnus-msg") - (autoload 'gnus-add-minor-mode "gnus-ems") + (autoload 'gnus-make-local-hook "gnus-util") (autoload 'message-fetch-field "message") - (autoload 'message-posting-charset "message")) + (autoload 'message-mark-active-p "message") + (autoload 'fill-flowed-encode "flow-fill") + (autoload 'message-posting-charset "message") + (autoload 'x-dnd-get-local-file-name "x-dnd")) (defcustom mml-content-type-parameters '(name access-type expiration size permission format) "*A list of acceptable parameters in MML tag. These parameters are generated in Content-Type header if exists." + :version "22.1" :type '(repeat (symbol :tag "Parameter")) :group 'message) @@ -48,9 +53,17 @@ These parameters are generated in Content-Type header if exists." '(filename creation-date modification-date read-date) "*A list of acceptable parameters in MML tag. These parameters are generated in Content-Disposition header if exists." + :version "22.1" :type '(repeat (symbol :tag "Parameter")) :group 'message) +(defcustom mml-insert-mime-headers-always nil + "If non-nil, always put Content-Type: text/plain at top of empty parts. +It is necessary to work against a bug in certain clients." + :version "22.1" + :type 'boolean + :group 'message) + (defvar mml-tweak-type-alist nil "A list of (TYPE . FUNCTION) for tweaking MML parts. TYPE is a string containing a regexp to match the MIME type. FUNCTION @@ -64,10 +77,10 @@ NAME is a string containing the name of the TWEAK parameter in the MML handle. FUNCTION is a Lisp function which is called with the MML handle to tweak the part.") -(defvar mml-tweak-sexp-alist +(defvar mml-tweak-sexp-alist '((mml-externalize-attachments . mml-tweak-externalize-attachments)) "A list of (SEXP . FUNCTION) for tweaking MML parts. -SEXP is a s-expression. If the evaluation of SEXP is non-nil, FUNCTION +SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION is called. FUNCTION is a Lisp function which is called with the MML handle to tweak the part.") @@ -122,19 +135,15 @@ one charsets.") (defun mml-destroy-buffers () (let (kill-buffer-hook) - (mapcar 'kill-buffer mml-buffer-list) + (mapc 'kill-buffer mml-buffer-list) (setq mml-buffer-list nil))) (defun mml-parse () "Parse the current buffer as an MML document." (save-excursion (goto-char (point-min)) - (let ((table (syntax-table))) - (unwind-protect - (progn - (set-syntax-table mml-syntax-table) - (mml-parse-1)) - (set-syntax-table table))))) + (with-syntax-table mml-syntax-table + (mml-parse-1)))) (defun mml-parse-1 () "Parse the current buffer as an MML document." @@ -142,6 +151,42 @@ one charsets.") (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond + ((looking-at "<#secure") + ;; The secure part is essentially a meta-meta tag, which + ;; expands to either a part tag if there are no other parts in + ;; the document or a multipart tag if there are other parts + ;; included in the message + (let* (secure-mode + (taginfo (mml-read-tag)) + (recipients (cdr (assq 'recipients taginfo))) + (sender (cdr (assq 'sender taginfo))) + (location (cdr (assq 'tag-location taginfo))) + (mode (cdr (assq 'mode taginfo))) + (method (cdr (assq 'method taginfo))) + tags) + (save-excursion + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t) + (setq secure-mode "multipart") + (setq secure-mode "part"))) + (save-excursion + (goto-char location) + (re-search-forward "<#secure[^\n]*>\n")) + (delete-region (match-beginning 0) (match-end 0)) + (cond ((string= mode "sign") + (setq tags (list "sign" method))) + ((string= mode "encrypt") + (setq tags (list "encrypt" method))) + ((string= mode "signencrypt") + (setq tags (list "sign" method "encrypt" method)))) + (eval `(mml-insert-tag ,secure-mode + ,@tags + ,(if recipients "recipients") + ,recipients + ,(if sender "sender") + ,sender)) + ;; restart the parse + (goto-char location))) ((looking-at "<#multipart") (push (nconc (mml-read-tag) (mml-parse-1)) struct)) ((looking-at "<#external") @@ -164,18 +209,18 @@ one charsets.") (list (intern (downcase (cdr (assq 'charset tag)))))) (t - (mm-find-mime-charset-region point (point) + (mm-find-mime-charset-region point (point) mm-hack-charsets)))) (when (and (not raw) (memq nil charsets)) (if (or (memq 'unknown-encoding mml-confirmation-set) (message-options-get 'unknown-encoding) (and (y-or-n-p "\ -Message contains characters with unknown encoding. Really send?") +Message contains characters with unknown encoding. Really send? ") (message-options-set 'unknown-encoding t))) (if (setq use-ascii (or (memq 'use-ascii mml-confirmation-set) (message-options-get 'use-ascii) - (and (y-or-n-p "Use ASCII as charset?") + (and (y-or-n-p "Use ASCII as charset? ") (message-options-set 'use-ascii t)))) (setq charsets (delq nil charsets)) (setq warn nil)) @@ -286,11 +331,20 @@ A message part needs to be split into %d charset parts. Really send? " (setq contents (append (list (cons 'tag-location orig-point)) contents)) (cons (intern name) (nreverse contents)))) +(defun mml-buffer-substring-no-properties-except-hard-newlines (start end) + (let ((str (buffer-substring-no-properties start end)) + (bufstart start) tmp) + (while (setq tmp (text-property-any start end 'hard 't)) + (set-text-properties (- tmp bufstart) (- tmp bufstart -1) + '(hard t) str) + (setq start (1+ tmp))) + str)) + (defun mml-read-part (&optional mml) "Return the buffer up till the next part, multipart or closing part or multipart. If MML is non-nil, return the buffer up till the correspondent mml tag." (let ((beg (point)) (count 1)) - ;; If the tag ended at the end of the line, we go to the next line. + ;; If the tag ended at the end of the line, we go to the next line. (when (looking-at "[ \t]*\n") (forward-line 1)) (if mml @@ -299,19 +353,22 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (if (re-search-forward "<#\\(/\\)?mml." nil t) (setq count (+ count (if (match-beginning 1) -1 1))) (goto-char (point-max)))) - (buffer-substring-no-properties beg (if (> count 0) - (point) - (match-beginning 0)))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (if (> count 0) + (point) + (match-beginning 0)))) (if (re-search-forward "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t) (prog1 - (buffer-substring-no-properties beg (match-beginning 0)) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (match-beginning 0)) (if (or (not (match-beginning 1)) (equal (match-string 2) "multipart")) (goto-char (match-beginning 0)) (when (looking-at "[ \t]*\n") (forward-line 1)))) - (buffer-substring-no-properties beg (goto-char (point-max))))))) + (mml-buffer-substring-no-properties-except-hard-newlines + beg (goto-char (point-max))))))) (defvar mml-boundary nil) (defvar mml-base-boundary "-=-=") @@ -340,22 +397,25 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (cond ((or (eq (car cont) 'part) (eq (car cont) 'mml)) (let ((raw (cdr (assq 'raw cont))) - coded encoding charset filename type) - (setq type (or (cdr (assq 'type cont)) "text/plain")) + type charset coding filename encoding flowed coded) + (setq type (or (cdr (assq 'type cont)) "text/plain") + charset (cdr (assq 'charset cont)) + coding (mm-charset-to-coding-system charset)) + (cond ((eq coding 'ascii) + (setq charset nil + coding nil)) + (charset + (setq charset (intern (downcase charset))))) (if (and (not raw) (member (car (split-string type "/")) '("text" "message"))) (progn (with-temp-buffer - (setq charset (mm-charset-to-coding-system - (cdr (assq 'charset cont)))) - (when (eq charset 'ascii) - (setq charset nil)) (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) ((and (setq filename (cdr (assq 'filename cont))) (not (equal (cdr (assq 'nofile cont)) "yes"))) - (let ((coding-system-for-read charset)) + (let ((coding-system-for-read coding)) (mm-insert-file-contents filename))) ((eq 'mml (car cont)) (insert (cdr (assq 'contents cont)))) @@ -372,8 +432,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (+ (match-beginning 0) 3)))))) (cond ((eq (car cont) 'mml) - (let ((mml-boundary (funcall mml-boundary-function - (incf mml-multipart-number))) + (let ((mml-boundary (mml-compute-boundary cont)) (mml-generate-default-type "text/plain")) (mml-to-mime)) (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b"))) @@ -384,26 +443,50 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." ;; ignore 0x1b, it is part of iso-2022-jp (setq encoding (mm-body-7-or-8)))) (t + ;; Only perform format=flowed filling on text/plain + ;; parts where there either isn't a format parameter + ;; in the mml tag or it says "flowed" and there + ;; actually are hard newlines in the text. + (let (use-hard-newlines) + (when (and (string= type "text/plain") + (not (string= (cdr (assq 'sign cont)) "pgp")) + (or (null (assq 'format cont)) + (string= (cdr (assq 'format cont)) + "flowed")) + (setq use-hard-newlines + (text-property-any + (point-min) (point-max) 'hard 't))) + (fill-flowed-encode) + ;; Indicate that `mml-insert-mime-headers' should + ;; insert a "; format=flowed" string unless the + ;; user has already specified it. + (setq flowed (null (assq 'format cont))))) (setq charset (mm-encode-body charset)) (setq encoding (mm-body-encoding charset (cdr (assq 'encoding cont)))))) (setq coded (buffer-string))) - (mml-insert-mime-headers cont type charset encoding) + (mml-insert-mime-headers cont type charset encoding flowed) (insert "\n") (insert coded)) (mm-with-unibyte-buffer (cond ((cdr (assq 'buffer cont)) - (insert-buffer-substring (cdr (assq 'buffer cont)))) + (insert (with-current-buffer (cdr (assq 'buffer cont)) + (mm-with-unibyte-current-buffer + (buffer-string))))) ((and (setq filename (cdr (assq 'filename cont))) (not (equal (cdr (assq 'nofile cont)) "yes"))) (let ((coding-system-for-read mm-binary-coding-system)) - (mm-insert-file-contents filename nil nil nil nil t))) + (mm-insert-file-contents filename nil nil nil nil t)) + (unless charset + (setq charset (mm-coding-system-to-mime-charset + (mm-find-buffer-file-coding-system + filename))))) (t (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) coded (mm-string-as-multibyte (buffer-string)))) - (mml-insert-mime-headers cont type charset encoding) + (mml-insert-mime-headers cont type charset encoding nil) (insert "\n") (mm-with-unibyte-current-buffer (insert coded))))) @@ -455,8 +538,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (funcall (cdr handler) cont) ;; No specific handler. Use default one. (let ((mml-boundary (mml-compute-boundary cont))) - (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" - type mml-boundary)) + (insert (format "Content-Type: multipart/%s; boundary=\"%s\"" + type mml-boundary) + (if (cdr (assq 'start cont)) + (format "; start=\"%s\"\n" (cdr (assq 'start cont))) + "\n")) (let ((cont cont) part) (while (setq part (pop cont)) ;; Skip `multipart' and attributes. @@ -466,22 +552,31 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (insert "\n--" mml-boundary "--\n"))))) (t (error "Invalid element: %S" cont))) - (let ((item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) - sender recipients) - (when item - (if (setq sender (cdr (assq 'sender cont))) - (message-options-set 'message-sender sender)) - (if (setq recipients (cdr (assq 'recipients cont))) - (message-options-set 'message-sender recipients)) - (funcall (nth 1 item) cont))) - (let ((item (assoc (cdr (assq 'encrypt cont)) mml-encrypt-alist)) + ;; handle sign & encrypt tags in a semi-smart way. + (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist)) + (encrypt-item (assoc (cdr (assq 'encrypt cont)) + mml-encrypt-alist)) sender recipients) - (when item - (if (setq sender (cdr (assq 'sender cont))) - (message-options-set 'message-sender sender)) + (when (or sign-item encrypt-item) + (when (setq sender (cdr (assq 'sender cont))) + (message-options-set 'mml-sender sender) + (message-options-set 'message-sender sender)) (if (setq recipients (cdr (assq 'recipients cont))) - (message-options-set 'message-sender recipients)) - (funcall (nth 1 item) cont)))))) + (message-options-set 'message-recipients recipients)) + (let ((style (mml-signencrypt-style + (first (or sign-item encrypt-item))))) + ;; check if: we're both signing & encrypting, both methods + ;; are the same (why would they be different?!), and that + ;; the signencrypt style allows for combined operation. + (if (and sign-item encrypt-item (equal (first sign-item) + (first encrypt-item)) + (equal style 'combined)) + (funcall (nth 1 encrypt-item) cont t) + ;; otherwise, revert to the old behavior. + (when sign-item + (funcall (nth 1 sign-item) cont)) + (when encrypt-item + (funcall (nth 1 encrypt-item) cont))))))))) (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." @@ -503,7 +598,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (insert-buffer-substring (cdr (assq 'buffer cont)))) ((and (setq filename (cdr (assq 'filename cont))) (not (equal (cdr (assq 'nofile cont)) "yes"))) - (mm-insert-file-contents filename)) + (mm-insert-file-contents filename nil nil nil nil t)) (t (insert (cdr (assq 'contents cont))))) (goto-char (point-min)) @@ -513,7 +608,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) - (mapcar 'mml-compute-boundary-1 (cddr cont)))) + (mapc 'mml-compute-boundary-1 (cddr cont)))) t)) (defun mml-make-boundary (number) @@ -523,25 +618,31 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." "") mml-base-boundary)) -(defun mml-insert-mime-headers (cont type charset encoding) - (let (parameters disposition description) +(defun mml-insert-mime-headers (cont type charset encoding flowed) + (let (parameters id disposition description) (setq parameters (mml-parameter-string cont mml-content-type-parameters)) (when (or charset parameters - (not (equal type mml-generate-default-type))) + flowed + (not (equal type mml-generate-default-type)) + mml-insert-mime-headers-always) (when (consp charset) (error - "Can't encode a part with several charsets.")) + "Can't encode a part with several charsets")) (insert "Content-Type: " type) (when charset (insert "; " (mail-header-encode-parameter "charset" (symbol-name charset)))) + (when flowed + (insert "; format=flowed")) (when parameters (mml-insert-parameter-string cont mml-content-type-parameters)) (insert "\n")) + (when (setq id (cdr (assq 'id cont))) + (insert "Content-ID: " id "\n")) (setq parameters (mml-parameter-string cont mml-content-disposition-parameters)) @@ -636,6 +737,9 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (message-encode-message-body) (save-restriction (message-narrow-to-headers-or-head) + ;; Skip past any From_ headers. + (while (looking-at "From ") + (forward-line 1)) (let ((mail-parse-charset message-default-charset)) (mail-encode-encoded-word-buffer)))) @@ -657,7 +761,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (mml-insert-mml-markup handle buffer textp))) (cond (mmlp - (insert-buffer buffer) + (insert-buffer-substring buffer) (goto-char (point-max)) (insert "<#/mml>\n")) ((stringp (car handle)) @@ -665,10 +769,12 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (insert "<#/multipart>\n")) (textp (let ((charset (mail-content-type-get - (mm-handle-type handle) 'charset))) + (mm-handle-type handle) 'charset)) + (start (point))) (if (eq charset 'gnus-decoded) (mm-insert-part handle) - (insert (mm-decode-string (mm-get-part handle) charset)))) + (insert (mm-decode-string (mm-get-part handle) charset))) + (mml-quote-region start (point))) (goto-char (point-max))) (t (insert "<#/part>\n"))))) @@ -676,8 +782,12 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp) "Take a MIME handle and insert an MML tag." (if (stringp (car handle)) - (insert "<#multipart type=" (mm-handle-media-subtype handle) - ">\n") + (progn + (insert "<#multipart type=" (mm-handle-media-subtype handle)) + (let ((start (mm-handle-multipart-ctl-parameter handle 'start))) + (when start + (insert " start=\"" start "\""))) + (insert ">\n")) (if mmlp (insert "<#mml type=" (mm-handle-media-type handle)) (insert "<#part type=" (mm-handle-media-type handle))) @@ -685,6 +795,8 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (cdr (mm-handle-disposition handle)))) (unless (symbolp (cdr elem)) (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))) + (when (mm-handle-id handle) + (insert " id=\"" (mm-handle-id handle) "\"")) (when (mm-handle-disposition handle) (insert " disposition=" (car (mm-handle-disposition handle)))) (when buffer @@ -703,7 +815,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (insert " " param) (when (> (current-column) 71) (goto-char point) - (insert "\n ") + (insert "\n") (end-of-line))))) ;;; @@ -713,14 +825,23 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (defvar mml-mode-map (let ((sign (make-sparse-keymap)) (encrypt (make-sparse-keymap)) + (signpart (make-sparse-keymap)) + (encryptpart (make-sparse-keymap)) (map (make-sparse-keymap)) (main (make-sparse-keymap))) - (define-key sign "p" 'mml-secure-sign-pgpmime) - (define-key sign "o" 'mml-secure-sign-pgp) - (define-key sign "s" 'mml-secure-sign-smime) - (define-key encrypt "p" 'mml-secure-encrypt-pgpmime) - (define-key encrypt "o" 'mml-secure-encrypt-pgp) - (define-key encrypt "s" 'mml-secure-encrypt-smime) + (define-key sign "p" 'mml-secure-message-sign-pgpmime) + (define-key sign "o" 'mml-secure-message-sign-pgp) + (define-key sign "s" 'mml-secure-message-sign-smime) + (define-key signpart "p" 'mml-secure-sign-pgpmime) + (define-key signpart "o" 'mml-secure-sign-pgp) + (define-key signpart "s" 'mml-secure-sign-smime) + (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime) + (define-key encrypt "o" 'mml-secure-message-encrypt-pgp) + (define-key encrypt "s" 'mml-secure-message-encrypt-smime) + (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime) + (define-key encryptpart "o" 'mml-secure-encrypt-pgp) + (define-key encryptpart "s" 'mml-secure-encrypt-smime) + (define-key map "\C-n" 'mml-unsecure-message) (define-key map "f" 'mml-attach-file) (define-key map "b" 'mml-attach-buffer) (define-key map "e" 'mml-attach-external) @@ -730,7 +851,9 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (define-key map "v" 'mml-validate) (define-key map "P" 'mml-preview) (define-key map "s" sign) + (define-key map "S" signpart) (define-key map "c" encrypt) + (define-key map "C" encryptpart) ;;(define-key map "n" 'mml-narrow-to-part) ;; `M-m' conflicts with `back-to-indentation'. ;; (define-key main "\M-m" map) @@ -740,21 +863,32 @@ If HANDLES is non-nil, use it instead reparsing the buffer." (easy-menu-define mml-menu mml-mode-map "" `("Attachments" - ["Attach File" mml-attach-file + ["Attach File..." mml-attach-file ,@(if (featurep 'xemacs) '(t) '(:help "Attach a file at point"))] - ["Attach Buffer" mml-attach-buffer t] - ["Attach External" mml-attach-external t] - ["Insert Part" mml-insert-part t] - ["Insert Multipart" mml-insert-multipart t] - ["PGP/MIME Sign" mml-secure-sign-pgpmime t] - ["PGP/MIME Encrypt" mml-secure-encrypt-pgpmime t] - ["PGP Sign" mml-secure-sign-pgp t] - ["PGP Encrypt" mml-secure-encrypt-pgp t] - ["S/MIME Sign" mml-secure-sign-smime t] - ["S/MIME Encrypt" mml-secure-encrypt-smime t] + ["Attach Buffer..." mml-attach-buffer t] + ["Attach External..." mml-attach-external t] + ["Insert Part..." mml-insert-part t] + ["Insert Multipart..." mml-insert-multipart t] + ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t] + ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t] + ["PGP Sign" mml-secure-message-sign-pgp t] + ["PGP Encrypt" mml-secure-message-encrypt-pgp t] + ["S/MIME Sign" mml-secure-message-sign-smime t] + ["S/MIME Encrypt" mml-secure-message-encrypt-smime t] + ("Secure MIME part" + ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t] + ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t] + ["PGP Sign Part" mml-secure-sign-pgp t] + ["PGP Encrypt Part" mml-secure-encrypt-pgp t] + ["S/MIME Sign Part" mml-secure-sign-smime t] + ["S/MIME Encrypt Part" mml-secure-encrypt-smime t]) + ["Encrypt/Sign off" mml-unsecure-message t] ;;["Narrow" mml-narrow-to-part t] - ["Quote MML" mml-quote-region t] + ["Quote MML" mml-quote-region + :active (message-mark-active-p) + ,@(if (featurep 'xemacs) nil + '(:help "Quote MML tags in region"))] ["Validate MML" mml-validate t] ["Preview" mml-preview t])) @@ -771,8 +905,13 @@ See Info node `(emacs-mime)Composing'. (when (set (make-local-variable 'mml-mode) (if (null arg) (not mml-mode) (> (prefix-numeric-value arg) 0))) - (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map) + (add-minor-mode 'mml-mode " MML" mml-mode-map) (easy-menu-add mml-menu mml-mode-map) + (when (boundp 'x-dnd-protocol-alist) + (set (make-local-variable 'x-dnd-protocol-alist) + '(("^file:///" . mml-x-dnd-attach-file) + ("^file://" . x-dnd-open-file) + ("^file:" . mml-x-dnd-attach-file)))) (run-hooks 'mml-mode-hook))) ;;; @@ -781,8 +920,9 @@ See Info node `(emacs-mime)Composing'. ;;; (defun mml-minibuffer-read-file (prompt) - (let ((file (read-file-name prompt nil nil t))) - ;; Prevent some common errors. This is inspired by similar code in + (let* ((completion-ignored-extensions nil) + (file (read-file-name prompt nil nil t))) + ;; 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)) @@ -813,6 +953,18 @@ See Info node `(emacs-mime)Composing'. (setq description nil)) description)) +(defun mml-minibuffer-read-disposition (type &optional default) + (let* ((default (or default + (if (string-match "^text/.*" type) + "inline" + "attachment"))) + (disposition (completing-read "Disposition: " + '(("attachment") ("inline") ("")) + nil t))) + (if (not (equal disposition "")) + disposition + default))) + (defun mml-quote-region (beg end) "Quote the MML tags in the region." (interactive "r") @@ -840,7 +992,9 @@ See Info node `(emacs-mime)Composing'. (when value ;; Quote VALUE if it contains suspicious characters. (when (string-match "[\"'\\~/*;() \t\n]" value) - (setq value (prin1-to-string value))) + (setq value (with-output-to-string + (let (print-escape-nonascii) + (prin1 value))))) (insert (format " %s=%s" key value))))) (insert ">\n")) @@ -853,7 +1007,7 @@ See Info node `(emacs-mime)Composing'. ;;; Attachment functions. -(defun mml-attach-file (file &optional type description) +(defun mml-attach-file (file &optional type description disposition) "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]'. @@ -864,10 +1018,23 @@ description of the attachment." (interactive (let* ((file (mml-minibuffer-read-file "Attach file: ")) (type (mml-minibuffer-read-type file)) - (description (mml-minibuffer-read-description))) - (list file type description))) - (mml-insert-empty-tag 'part 'type type 'filename file - 'disposition "attachment" 'description description)) + (description (mml-minibuffer-read-description)) + (disposition (mml-minibuffer-read-disposition type))) + (list file type description disposition))) + (mml-insert-empty-tag 'part + 'type type + 'filename file + 'disposition (or disposition "attachment") + 'description description)) + +(defun mml-x-dnd-attach-file (uri action) + "Attach a drag and drop file." + (let ((file (x-dnd-get-local-file-name uri t))) + (when (and file (file-regular-p file)) + (let* ((type (mml-minibuffer-read-type file)) + (description (mml-minibuffer-read-description)) + (disposition (mml-minibuffer-read-disposition type))) + (mml-attach-file file type description disposition))))) (defun mml-attach-buffer (buffer &optional type description) "Attach a buffer to the outgoing MIME message. @@ -908,45 +1075,93 @@ TYPE is the MIME type to use." (mml-insert-tag 'part 'type type 'disposition "inline") (forward-line -1)) +(defun mml-preview-insert-mail-followup-to () + "Insert a Mail-Followup-To header before previewing an article. +Should be adopted if code in `message-send-mail' is changed." + (when (and (message-mail-p) + (message-subscribed-p) + (not (mail-fetch-field "mail-followup-to")) + (message-make-mail-followup-to)) + (message-position-on-field "Mail-Followup-To" "X-Draft-From") + (insert (message-make-mail-followup-to)))) + +(defvar mml-preview-buffer nil) + (defun mml-preview (&optional raw) "Display current buffer with Gnus, in a new buffer. If RAW, don't highlight the article." (interactive "P") - (let* ((buf (current-buffer)) - (message-options message-options) - (message-this-is-news (message-news-p)) - (message-posting-charset (or (gnus-setup-posting-charset - (save-restriction - (message-narrow-to-headers-or-head) - (message-fetch-field "Newsgroups"))) - message-posting-charset))) - (message-options-set-recipient) - (switch-to-buffer (generate-new-buffer - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) - (erase-buffer) - (insert-buffer buf) - (if (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n") nil t) - (replace-match "\n")) - (let ((mail-header-separator "")) ;; mail-header-separator is removed. - (mml-to-mime)) - (if raw - (when (fboundp 'set-buffer-multibyte) - (let ((s (buffer-string))) - ;; Insert the content into unibyte buffer. - (erase-buffer) - (mm-disable-multibyte) - (insert s))) - (let ((gnus-newsgroup-charset (car message-posting-charset))) - (run-hooks 'gnus-article-decode-hook) - (let ((gnus-newsgroup-name "dummy")) - (gnus-article-prepare-display)))) - ;; Disable article-mode-map. - (use-local-map nil) - (setq buffer-read-only t) - (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) - (goto-char (point-min)))) + (setq mml-preview-buffer (generate-new-buffer + (concat (if raw "*Raw MIME preview of " + "*MIME preview of ") (buffer-name)))) + (save-excursion + (let* ((buf (current-buffer)) + (message-options message-options) + (message-this-is-mail (message-mail-p)) + (message-this-is-news (message-news-p)) + (message-posting-charset (or (gnus-setup-posting-charset + (save-restriction + (message-narrow-to-headers-or-head) + (message-fetch-field "Newsgroups"))) + message-posting-charset))) + (message-options-set-recipient) + (when (boundp 'gnus-buffers) + (push mml-preview-buffer gnus-buffers)) + (save-restriction + (widen) + (set-buffer mml-preview-buffer) + (erase-buffer) + (insert-buffer-substring buf)) + (mml-preview-insert-mail-followup-to) + (let ((message-deletable-headers (if (message-news-p) + nil + message-deletable-headers))) + (message-generate-headers + (copy-sequence (if (message-news-p) + message-required-news-headers + message-required-mail-headers)))) + (if (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n") nil t) + (replace-match "\n")) + (let ((mail-header-separator ""));; mail-header-separator is removed. + (message-sort-headers) + (mml-to-mime)) + (if raw + (when (fboundp 'set-buffer-multibyte) + (let ((s (buffer-string))) + ;; Insert the content into unibyte buffer. + (erase-buffer) + (mm-disable-multibyte) + (insert s))) + (let ((gnus-newsgroup-charset (car message-posting-charset)) + gnus-article-prepare-hook gnus-original-article-buffer) + (run-hooks 'gnus-article-decode-hook) + (let ((gnus-newsgroup-name "dummy") + (gnus-newsrc-hashtb (or gnus-newsrc-hashtb + (gnus-make-hashtable 5)))) + (gnus-article-prepare-display)))) + ;; Disable article-mode-map. + (use-local-map nil) + (gnus-make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook + (lambda () + (mm-destroy-parts gnus-article-mime-handles)) nil t) + (setq buffer-read-only t) + (local-set-key "q" (lambda () (interactive) (kill-buffer nil))) + (local-set-key "=" (lambda () (interactive) (delete-other-windows))) + (local-set-key "\r" + (lambda () + (interactive) + (widget-button-press (point)))) + (local-set-key gnus-mouse-2 + (lambda (event) + (interactive "@e") + (widget-button-press (widget-event-point event) event))) + (goto-char (point-min)))) + (if (and (boundp 'gnus-buffer-configuration) + (assq 'mml-preview gnus-buffer-configuration)) + (gnus-configure-windows 'mml-preview) + (pop-to-buffer mml-preview-buffer))) (defun mml-validate () "Validate the current MML document." @@ -983,7 +1198,7 @@ If RAW, don't highlight the article." (defun mml-tweak-externalize-attachments (cont) "Tweak attached files as external parts." (let (filename-cons) - (when (and (eq (car cont) 'part) + (when (and (eq (car cont) 'part) (not (cdr (assq 'buffer cont))) (and (setq filename-cons (assq 'filename cont)) (not (equal (cdr (assq 'nofile cont)) "yes")))) @@ -992,4 +1207,5 @@ If RAW, don't highlight the article." (provide 'mml) +;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12 ;;; mml.el ends here