X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml.el;h=320f6aa5a6dd6ab3adbc43445e5e05cef2c09ca2;hb=9c35917948e7e312fb8f3e9ff0d49b01fa3e9edf;hp=5c5efdc12b43dfc641141bc75e02446c905e6ce6;hpb=f9c8170d647a9e61dd1d8bb7c4f7d4d8c6721280;p=elisp%2Fgnus.git- diff --git a/lisp/mml.el b/lisp/mml.el index 5c5efdc..320f6aa 100644 --- a/lisp/mml.el +++ b/lisp/mml.el @@ -26,10 +26,23 @@ (require 'mm-util) (require 'mm-bodies) (require 'mm-encode) +(require 'mm-decode) (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) @@ -43,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)) @@ -55,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 @@ -72,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 @@ -89,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) @@ -201,13 +242,14 @@ ((eq (car cont) 'part) (let (coded encoding charset filename type) (setq type (or (cdr (assq 'type cont)) "text/plain")) - (if (equal (car (split-string type "/")) "text") + (if (member (car (split-string type "/")) '("text" "message")) (with-temp-buffer (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((setq filename (cdr (assq 'filename cont))) - (insert-file-contents-literally filename)) + ((and (setq filename (cdr (assq 'filename cont))) + (not (equal (cdr (assq 'nofile cont)) "yes"))) + (mm-insert-file-contents filename)) (t (save-restriction (narrow-to-region (point) (point)) @@ -219,14 +261,17 @@ (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 ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((setq filename (cdr (assq 'filename cont))) - (insert-file-contents-literally filename)) + ((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))) (t (insert (cdr (assq 'contents cont))))) (setq encoding (mm-encode-buffer type) @@ -242,21 +287,23 @@ (when name (setq name (mml-parse-file-name name)) (if (stringp name) - (insert ";\n " (mail-header-encode-parameter "name" name) - "\";\n access-type=local-file") - (insert - (format ";\n " - (mail-header-encode-parameter - "name" (file-name-nondirectory (nth 2 name))) - (mail-header-encode-parameter "site" (nth 1 name)) - (mail-header-encode-parameter - "directory" (file-name-directory (nth 2 name))))) - (insert ";\n access-type=" - (if (member (nth 0 name) '("ftp@" "anonymous@")) - "anon-ftp" - "ftp")))) + (mml-insert-parameter + (mail-header-encode-parameter "name" name) + "access-type=local-file") + (mml-insert-parameter + (mail-header-encode-parameter + "name" (file-name-nondirectory (nth 2 name))) + (mail-header-encode-parameter "site" (nth 1 name)) + (mail-header-encode-parameter + "directory" (file-name-directory (nth 2 name)))) + (mml-insert-parameter + (concat "access-type=" + (if (member (nth 0 name) '("ftp@" "anonymous@")) + "anon-ftp" + "ftp"))))) (when parameters - (insert parameters))) + (mml-insert-parameter-string + cont '(expiration size permission)))) (insert "\n\n") (insert "Content-Type: " (cdr (assq 'type cont)) "\n") (insert "Content-ID: " (message-make-message-id) "\n") @@ -266,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 @@ -296,23 +347,25 @@ (cond ((cdr (assq 'buffer cont)) (insert-buffer-substring (cdr (assq 'buffer cont)))) - ((setq filename (cdr (assq 'filename cont))) - (insert-file-contents-literally filename)) + ((and (setq filename (cdr (assq 'filename cont))) + (not (equal (cdr (assq 'nofile cont)) "yes"))) + (mm-insert-file-contents filename)) (t (insert (cdr (assq 'contents cont))))) (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)) @@ -338,7 +391,8 @@ (insert "; " (mail-header-encode-parameter "charset" (symbol-name charset)))) (when parameters - (insert parameters)) + (mml-insert-parameter-string + cont '(name access-type expiration size permission))) (insert "\n")) (setq parameters (mml-parameter-string @@ -347,7 +401,8 @@ parameters) (insert "Content-Disposition: " (or disposition "inline")) (when parameters - (insert parameters)) + (mml-insert-parameter-string + cont '(filename creation-date modification-date read-date))) (insert "\n")) (unless (eq encoding '7bit) (insert (format "Content-Transfer-Encoding: %s\n" encoding))) @@ -363,12 +418,23 @@ ;; Strip directory component from the filename parameter. (when (eq type 'filename) (setq value (file-name-nondirectory value))) - (setq string (concat string ";\n " + (setq string (concat string "; " (mail-header-encode-parameter (symbol-name type) value))))) (when (not (zerop (length string))) string))) +(defun mml-insert-parameter-string (cont types) + (let (value type) + (while (setq type (pop types)) + (when (setq value (cdr (assq type cont))) + ;; Strip directory component from the filename parameter. + (when (eq type 'filename) + (setq value (file-name-nondirectory value))) + (mml-insert-parameter + (mail-header-encode-parameter + (symbol-name type) value)))))) + (defvar ange-ftp-path-format) (defvar efs-path-regexp) (defun mml-parse-file-name (path) @@ -411,48 +477,63 @@ "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) (let (textp buffer) ;; Determine type and stuff. (unless (stringp (car handle)) - (unless (setq textp (equal - (car (split-string - (car (mm-handle-type handle)) "/")) - "text")) + (unless (setq textp (equal (mm-handle-media-supertype handle) + "text")) (save-excursion (set-buffer (setq buffer (generate-new-buffer " *mml*"))) (mm-insert-part handle)))) (unless no-markup - (mml-insert-mml-markup handle buffer)) + (mml-insert-mml-markup handle buffer textp)) (cond ((stringp (car handle)) (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"))))) -(defun mml-insert-mml-markup (handle &optional buffer) +(defun mml-insert-mml-markup (handle &optional buffer nofile) "Take a MIME handle and insert an MML tag." (if (stringp (car handle)) - (insert "<#multipart type=" (cadr (split-string (car handle) "/")) + (insert "<#multipart type=" (mm-handle-media-subtype handle) ">\n") - (insert "<#part type=" (car (mm-handle-type handle))) + (insert "<#part type=" (mm-handle-media-type handle)) (dolist (elem (append (cdr (mm-handle-type handle)) (cdr (mm-handle-disposition handle)))) (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")) + (when (mm-handle-disposition handle) + (insert " disposition=" (car (mm-handle-disposition handle)))) (when buffer (insert " buffer=\"" (buffer-name buffer) "\"")) + (when nofile + (insert " nofile=yes")) (when (mm-handle-description handle) (insert " description=\"" (mm-handle-description handle) "\"")) - (equal (split-string (car (mm-handle-type handle)) "/") "text") (insert ">\n"))) +(defun mml-insert-parameter (&rest parameters) + "Insert PARAMETERS in a nice way." + (dolist (param parameters) + (insert ";") + (let ((point (point))) + (insert " " param) + (when (> (current-column) 71) + (goto-char point) + (insert "\n ") + (end-of-line))))) + ;;; ;;; Mode for inserting and editing MML forms ;;; @@ -462,10 +543,13 @@ (main (make-sparse-keymap))) (define-key map "f" 'mml-attach-file) (define-key map "b" 'mml-attach-buffer) + (define-key map "e" 'mml-attach-external) (define-key map "q" 'mml-quote-region) (define-key map "m" 'mml-insert-multipart) - (define-key map "q" 'mml-insert-part) + (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)) @@ -474,12 +558,15 @@ '("MML" ("Attach" ["File" mml-attach-file t] - ["Buffer" mml-attach-buffer t]) + ["Buffer" mml-attach-buffer t] + ["External" mml-attach-external t]) ("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])) + ["Validate" mml-validate t] + ["Preview" mml-preview t])) (defvar mml-mode nil "Minor mode for editing MML.") @@ -501,7 +588,12 @@ minor-mode-map-alist))) (run-hooks 'mml-mode-hook)) -(defun mml-read-file (prompt) +;;; +;;; Helper functions for reading MIME stuff from the minibuffer and +;;; inserting stuff to the buffer. +;;; + +(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 ;; VM. @@ -513,22 +605,40 @@ (error "Permission denied: %s" file)) file)) -(defun mml-read-type (file) - (let* ((default (or (mm-default-file-encoding file) +(defun mml-minibuffer-read-type (name &optional default) + (let* ((default (or default + (mm-default-file-encoding name) ;; Perhaps here we should check what the file ;; looks like, and offer text/plain if it looks ;; like text/plain. "application/octet-stream")) (string (completing-read (format "Content type (default %s): " default) - (delete-duplicates - (mapcar (lambda (m) (list (cdr m))) mailcap-mime-extensions) - :test 'equal)))) + (mapcar + 'list + (mm-delete-duplicates + (nconc + (mapcar (lambda (m) (cdr m)) + mailcap-mime-extensions) + (apply + 'nconc + (mapcar + (lambda (l) + (delq nil + (mapcar + (lambda (m) + (let ((type (cdr (assq 'type (cdr m))))) + (if (equal (cadr (split-string type "/")) + "*") + nil + type))) + (cdr l)))) + mailcap-mime-data)))))))) (if (not (equal string "")) string default))) -(defun mml-read-description () +(defun mml-minibuffer-read-description () (let ((description (read-string "One line description: "))) (when (string-match "\\`[ \t]*\\'" description) (setq description nil)) @@ -538,12 +648,41 @@ "Quote the MML tags in the region." (interactive "r") (save-excursion - (goto-char beg) - ;; Quote parts. - (while (re-search-forward - "<#/?!*\\(multipart\\|part\\|external\\)" end t) - (goto-char (match-beginning 1)) - (insert "!")))) + (save-restriction + ;; Temporarily narrow the region to defend from changes + ;; invalidating END. + (narrow-to-region beg end) + (goto-char (point-min)) + ;; Quote parts. + (while (re-search-forward + "<#/?!*\\(multipart\\|part\\|external\\)" nil t) + ;; Insert ! after the #. + (goto-char (+ (match-beginning 0) 2)) + (insert "!"))))) + +(defun mml-insert-tag (name &rest plist) + "Insert an MML tag described by NAME and PLIST." + (when (symbolp name) + (setq name (symbol-name name))) + (insert "<#" name) + (while plist + (let ((key (pop plist)) + (value (pop plist))) + (when value + ;; Quote VALUE if it contains suspicious characters. + (when (string-match "[\"\\~/* \t\n]" value) + (setq value (prin1-to-string value))) + (insert (format " %s=%s" key value))))) + (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. (defun mml-attach-file (file &optional type description) "Attach a file to the outgoing MIME message. @@ -554,32 +693,78 @@ 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 (mml-read-file "Attach file: ")) - (type (mml-read-type file)) - (description (mml-read-description))) + (let* ((file (mml-minibuffer-read-file "Attach file: ")) + (type (mml-minibuffer-read-type file)) + (description (mml-minibuffer-read-description))) (list file type description))) - (insert - (format - "<#part type=%s name=%s filename=%s%s disposition=attachment><#/part>\n" - type (prin1-to-string (file-name-nondirectory file)) - (prin1-to-string file) - (if description - (format " description=%s" (prin1-to-string 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. +See `mml-attach-file' for details of operation." + (interactive + (let* ((buffer (read-buffer "Attach buffer: ")) + (type (mml-minibuffer-read-type buffer "text/plain")) + (description (mml-minibuffer-read-description))) + (list buffer type 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. FILE is an ange-ftp/efs specification of the part location. TYPE is the MIME type to use." (interactive - (let* ((file (mml-read-file "Attach external file: ")) - (type (mml-read-type file)) - (description (mml-read-description))) + (let* ((file (mml-minibuffer-read-file "Attach external file: ")) + (type (mml-minibuffer-read-type file)) + (description (mml-minibuffer-read-description))) (list file type description))) - (insert (format - "<#external type=%s name=%s disposition=attachment><#/external>\n" - type (prin1-to-string file)))) + (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"))) + (or type + (setq type "mixed")) + (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. +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) + (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." + (interactive) + (mml-parse)) (provide 'mml)