X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml.el;h=320f6aa5a6dd6ab3adbc43445e5e05cef2c09ca2;hb=9c35917948e7e312fb8f3e9ff0d49b01fa3e9edf;hp=286c8e4f9c72569ec831a73646f355ce5b9bfabb;hpb=0fc7cfe44d8a7e783f48ebd0a91a614f5a67842d;p=elisp%2Fgnus.git- diff --git a/lisp/mml.el b/lisp/mml.el index 286c8e4..320f6aa 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -31,6 +31,18 @@ (eval-and-compile (autoload 'message-make-message-id "message")) +(defvar mml-generate-multipart-alist + nil + "*Alist of multipart generation functions. + +Each entry has the form (NAME . FUNCTION), where +NAME: is a string containing the name of the part (without the +leading \"/multipart/\"), +FUNCTION: is a Lisp function which is called to generate the part. + +The Lisp function has to supply the appropriate MIME headers and the +contents of this part.") + (defvar mml-syntax-table (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) (modify-syntax-entry ?\\ "/" table) @@ -44,6 +56,20 @@ (modify-syntax-entry ?\' " " table) table)) +(defvar mml-boundary-function 'mml-make-boundary + "A function called to suggest a boundary. +The function may be called several times, and should try to make a new +suggestion each time. The function is called with one parameter, +which is a number that says how many times the function has been +called for this message.") + +(defvar mml-confirmation-set nil + "A list of symbols, each of which disables some warning. +`unknown-encoding': always send messages contain characters with +unknown encoding; `use-ascii': always use ASCII for those characters +with unknown encoding; `multipart': always send messages with more than +one charsets.") + (defun mml-parse () "Parse the current buffer as an MML document." (goto-char (point-min)) @@ -56,7 +82,7 @@ (defun mml-parse-1 () "Parse the current buffer as an MML document." - (let (struct tag point contents charsets warn) + (let (struct tag point contents charsets warn use-ascii) (while (and (not (eobp)) (not (looking-at "<#/multipart"))) (cond @@ -73,12 +99,23 @@ (setq point (point) contents (mml-read-part) charsets (mm-find-mime-charset-region point (point))) + (when (memq nil charsets) + (if (or (memq 'unknown-encoding mml-confirmation-set) + (y-or-n-p + "Warning: You message contains characters with unknown encoding. Really send?")) + (if (setq use-ascii + (or (memq 'use-ascii mml-confirmation-set) + (y-or-n-p "Use ASCII as charset?"))) + (setq charsets (delq nil charsets)) + (setq warn nil)) + (error "Edit your message to remove those characters"))) (if (< (length charsets) 2) (push (nconc tag (list (cons 'contents contents))) struct) (let ((nstruct (mml-parse-singlepart-with-multiple-charsets - tag point (point)))) + tag point (point) use-ascii))) (when (and warn + (not (memq 'multipart mml-confirmation-set)) (not (y-or-n-p (format @@ -90,17 +127,20 @@ (forward-line 1)) (nreverse struct))) -(defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end) +(defun mml-parse-singlepart-with-multiple-charsets + (orig-tag beg end &optional use-ascii) (save-excursion (narrow-to-region beg end) (goto-char (point-min)) - (let ((current (mm-mime-charset (char-charset (following-char)))) + (let ((current (or (mm-mime-charset (mm-charset-after)) + (and use-ascii 'us-ascii))) charset struct space newline paragraph) (while (not (eobp)) (cond ;; The charset remains the same. - ((or (eq (setq charset (mm-mime-charset - (char-charset (following-char)))) 'us-ascii) + ((or (eq (setq charset (mm-mime-charset (mm-charset-after))) + 'us-ascii) + (and use-ascii (not charset)) (eq charset current))) ;; The initial charset was ascii. ((eq current 'us-ascii) @@ -221,7 +261,8 @@ (delete-region (+ (match-beginning 0) 2) (+ (match-beginning 0) 3)))))) (setq charset (mm-encode-body)) - (setq encoding (mm-body-encoding charset)) + (setq encoding (mm-body-encoding charset + (cdr (assq 'encoding cont)))) (setq coded (buffer-string))) (mm-with-unibyte-buffer (cond @@ -229,7 +270,8 @@ (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)) + (let ((coding-system-for-read mm-binary-coding-system)) + (mm-insert-file-contents filename nil nil nil nil t))) (t (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) @@ -271,22 +313,26 @@ (insert (or (cdr (assq 'contents cont)))) (insert "\n")) ((eq (car cont) 'multipart) - (let ((mml-boundary (mml-compute-boundary cont))) - (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n" - (or (cdr (assq 'type cont)) "mixed") - mml-boundary)) - (insert "\n") - (setq cont (cddr cont)) - (while cont - (insert "\n--" mml-boundary "\n") - (mml-generate-mime-1 (pop cont))) - (insert "\n--" mml-boundary "--\n"))) + (let* ((type (or (cdr (assq 'type cont)) "mixed")) + (handler (assoc type mml-generate-multipart-alist))) + (if handler + (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)) + (setq cont (cddr cont)) + (while cont + (insert "\n--" mml-boundary "\n") + (mml-generate-mime-1 (pop cont))) + (insert "\n--" mml-boundary "--\n"))))) (t (error "Invalid element: %S" cont)))) (defun mml-compute-boundary (cont) "Return a unique boundary that does not exist in CONT." - (let ((mml-boundary (mml-make-boundary))) + (let ((mml-boundary (funcall mml-boundary-function + (incf mml-multipart-number)))) ;; This function tries again and again until it has found ;; a unique boundary. (while (not (catch 'not-unique @@ -309,16 +355,17 @@ (goto-char (point-min)) (when (re-search-forward (concat "^--" (regexp-quote mml-boundary)) nil t) - (setq mml-boundary (mml-make-boundary)) + (setq mml-boundary (funcall mml-boundary-function + (incf mml-multipart-number))) (throw 'not-unique nil)))) ((eq (car cont) 'multipart) (mapcar 'mml-compute-boundary-1 (cddr cont)))) t)) -(defun mml-make-boundary () - (concat (make-string (% (incf mml-multipart-number) 60) ?=) - (if (> mml-multipart-number 17) - (format "%x" mml-multipart-number) +(defun mml-make-boundary (number) + (concat (make-string (% number 60) ?=) + (if (> number 17) + (format "%x" number) "") mml-base-boundary)) @@ -430,7 +477,7 @@ "Translate the current buffer from MML to MIME." (message-encode-message-body) (save-restriction - (message-narrow-to-headers) + (message-narrow-to-headers-or-head) (mail-encode-encoded-word-buffer))) (defun mml-insert-mime (handle &optional no-markup) @@ -449,7 +496,10 @@ (mapcar 'mml-insert-mime (cdr handle)) (insert "<#/multipart>\n")) (textp - (mm-insert-part handle) + (let ((text (mm-get-part handle)) + (charset (mail-content-type-get + (mm-handle-type handle) 'charset))) + (insert (mm-decode-string text charset))) (goto-char (point-max))) (t (insert "<#/part>\n"))))) @@ -499,6 +549,7 @@ (define-key map "p" 'mml-insert-part) (define-key map "v" 'mml-validate) (define-key map "P" 'mml-preview) + (define-key map "n" 'mml-narrow-to-part) (define-key main "\M-m" map) main)) @@ -512,6 +563,7 @@ ("Insert" ["Multipart" mml-insert-multipart t] ["Part" mml-insert-part t]) + ["Narrow" mml-narrow-to-part t] ["Quote" mml-quote-region t] ["Validate" mml-validate t] ["Preview" mml-preview t])) @@ -564,7 +616,7 @@ (format "Content type (default %s): " default) (mapcar 'list - (delete-duplicates + (mm-delete-duplicates (nconc (mapcar (lambda (m) (cdr m)) mailcap-mime-extensions) @@ -581,8 +633,7 @@ nil type))) (cdr l)))) - mailcap-mime-data))) - :test 'equal))))) + mailcap-mime-data)))))))) (if (not (equal string "")) string default))) @@ -605,7 +656,8 @@ ;; Quote parts. (while (re-search-forward "<#/?!*\\(multipart\\|part\\|external\\)" nil t) - (goto-char (match-beginning 1)) + ;; Insert ! after the #. + (goto-char (+ (match-beginning 0) 2)) (insert "!"))))) (defun mml-insert-tag (name &rest plist) @@ -621,7 +673,14 @@ (when (string-match "[\"\\~/* \t\n]" value) (setq value (prin1-to-string value))) (insert (format " %s=%s" key value))))) - (insert ">\n<#/" name ">\n")) + (insert ">\n")) + +(defun mml-insert-empty-tag (name &rest plist) + "Insert an empty MML tag described by NAME and PLIST." + (when (symbolp name) + (setq name (symbol-name name))) + (apply #'mml-insert-tag name plist) + (insert "<#/" name ">\n")) ;;; Attachment functions. @@ -638,8 +697,8 @@ description of the attachment." (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description))) (list file type description))) - (mml-insert-tag 'part 'type type 'filename file 'disposition "attachment" - 'description description)) + (mml-insert-empty-tag 'part 'type type 'filename file + 'disposition "attachment" 'description description)) (defun mml-attach-buffer (buffer &optional type description) "Attach a buffer to the outgoing MIME message. @@ -649,8 +708,8 @@ See `mml-attach-file' for details of operation." (type (mml-minibuffer-read-type buffer "text/plain")) (description (mml-minibuffer-read-description))) (list buffer type description))) - (mml-insert-tag 'part 'type type 'buffer buffer 'disposition "attachment" - 'description description)) + (mml-insert-empty-tag 'part 'type type 'buffer buffer + 'disposition "attachment" 'description description)) (defun mml-attach-external (file &optional type description) "Attach an external file into the buffer. @@ -661,37 +720,46 @@ TYPE is the MIME type to use." (type (mml-minibuffer-read-type file)) (description (mml-minibuffer-read-description))) (list file type description))) - (mml-insert-tag 'external 'type type 'name file 'disposition "attachment" - 'description description)) + (mml-insert-empty-tag 'external 'type type 'name file + 'disposition "attachment" 'description description)) (defun mml-insert-multipart (&optional type) (interactive (list (completing-read "Multipart type (default mixed): " - '(("mixed") ("alternative") ("digest") ("parallel") - ("signed") ("encrypted")) - nil nil "mixed"))) + '(("mixed") ("alternative") ("digest") ("parallel") + ("signed") ("encrypted")) + nil nil "mixed"))) (or type (setq type "mixed")) - (mml-insert-tag "multipart" 'type type) + (mml-insert-empty-tag "multipart" 'type type) + (forward-line -1)) + +(defun mml-insert-part (&optional type) + (interactive + (list (mml-minibuffer-read-type ""))) + (mml-insert-tag 'part 'type type 'disposition "inline") (forward-line -1)) (defun mml-preview (&optional raw) - "Display current buffer with Gnus, in a new buffer. + "Display current buffer with Gnus, in a new buffer. If RAW, don't highlight the article." - (interactive "P") - (let ((buf (current-buffer))) - (switch-to-buffer (get-buffer-create - (concat (if raw "*Raw MIME preview of " - "*MIME preview of ") (buffer-name)))) - (erase-buffer) - (insert-buffer buf) - (mml-to-mime) - (unless raw - (run-hooks 'gnus-article-decode-hook) - (let ((gnus-newsgroup-name "dummy")) - (gnus-article-prepare-display))) - (fundamental-mode) - (setq buffer-read-only t) - (goto-char (point-min)))) + (interactive "P") + (let ((buf (current-buffer))) + (switch-to-buffer (get-buffer-create + (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")) + (mml-to-mime) + (unless raw + (run-hooks 'gnus-article-decode-hook) + (let ((gnus-newsgroup-name "dummy")) + (gnus-article-prepare-display))) + (fundamental-mode) + (setq buffer-read-only t) + (goto-char (point-min)))) (defun mml-validate () "Validate the current MML document."