diff options
Diffstat (limited to 'lisp/gnus/mml.el')
| -rw-r--r-- | lisp/gnus/mml.el | 66 |
1 files changed, 58 insertions, 8 deletions
diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 439d7c5dc13..726faeed6a0 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -22,16 +22,13 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) - (require 'mm-util) (require 'mm-bodies) (require 'mm-encode) (require 'mm-decode) (require 'mml-sec) (eval-when-compile (require 'cl)) +(eval-when-compile (require 'url)) (eval-when-compile (when (featurep 'xemacs) (require 'easy-mmode))) ; for `define-minor-mode' @@ -463,6 +460,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag." (defvar mml-multipart-number 0) (defvar mml-inhibit-compute-boundary nil) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) + (defun mml-generate-mime (&optional multipart-type) "Generate a MIME message based on the current MML document. MULTIPART-TYPE defaults to \"mixed\", but can also @@ -472,19 +472,69 @@ be \"related\" or \"alternate\"." (options message-options)) (if (not cont) nil + (when (and (consp (car cont)) + (= (length cont) 1) + (fboundp 'libxml-parse-html-region) + (equal (cdr (assq 'type (car cont))) "text/html")) + (setq cont (mml-expand-html-into-multipart-related (car cont)))) (prog1 (mm-with-multibyte-buffer (setq message-options options) - (if (and (consp (car cont)) - (= (length cont) 1)) - (mml-generate-mime-1 (car cont)) + (cond + ((and (consp (car cont)) + (= (length cont) 1)) + (mml-generate-mime-1 (car cont))) + ((eq (car cont) 'multipart) + (mml-generate-mime-1 cont)) + (t (mml-generate-mime-1 (nconc (list 'multipart (cons 'type (or multipart-type "mixed"))) - cont))) + cont)))) (setq options message-options) (buffer-string)) (setq message-options options))))) +(defun mml-expand-html-into-multipart-related (cont) + (let ((new-parts nil) + (cid 1)) + (mm-with-multibyte-buffer + (insert (cdr (assq 'contents cont))) + (goto-char (point-min)) + (with-syntax-table mml-syntax-table + (while (re-search-forward "<img\\b" nil t) + (goto-char (match-beginning 0)) + (let* ((start (point)) + (img (nth 2 + (nth 2 + (libxml-parse-html-region + (point) (progn (forward-sexp) (point)))))) + (end (point)) + (parsed (url-generic-parse-url (cdr (assq 'src (cadr img)))))) + (when (and (null (url-type parsed)) + (url-filename parsed) + (file-exists-p (url-filename parsed))) + (goto-char start) + (when (search-forward (url-filename parsed) end t) + (let ((cid (format "fsf.%d" cid))) + (replace-match (concat "cid:" cid) t t) + (push (list cid (url-filename parsed)) new-parts)) + (setq cid (1+ cid))))))) + ;; We have local images that we want to include. + (if (not new-parts) + (list cont) + (setcdr (assq 'contents cont) (buffer-string)) + (setq cont + (nconc (list 'multipart (cons 'type "related")) + (list cont))) + (dolist (new-part (nreverse new-parts)) + (setq cont + (nconc cont + (list `(part (type . "image/png") + (filename . ,(nth 1 new-part)) + (id . ,(concat "<" (nth 0 new-part) + ">"))))))) + cont)))) + (defun mml-generate-mime-1 (cont) (let ((mm-use-ultra-safe-encoding (or mm-use-ultra-safe-encoding (assq 'sign cont)))) |