Identify unsafe combinations of Bcc and encryption

[gnus] / lisp / mml.el

diff --git a/lisp/mml.el b/lisp/mml.el
index cf90257..5754475 100644 (file)
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,6 +1,6 @@
 ;;; mml.el --- A package for parsing and validating MML documents
 
-;; Copyright (C) 1998-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -28,6 +28,7 @@
 (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'
@@ -256,7 +257,9 @@ part.  This is for the internal use, you should never modify the value.")
                ((string= mode "encrypt")
                 (setq tags (list "encrypt" method)))
                ((string= mode "signencrypt")
-                (setq tags (list "sign" method "encrypt" method))))
+                (setq tags (list "sign" method "encrypt" method)))
+               (t
+                (error "Unknown secure mode %s" mode)))
          (eval `(mml-insert-tag ,secure-mode
                                 ,@tags
                                 ,(if keyfile "keyfile")
@@ -459,6 +462,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 discard-comments))
+
 (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
@@ -468,19 +474,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))))