(install): Don't check for the file names.

[elisp/gnus.git-] / lisp / mml.el

diff --git a/lisp/mml.el b/lisp/mml.el
index 86faed8..589988c 100644 (file)
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -27,7 +27,8 @@
 (require 'mm-bodies)
 (require 'mm-encode)
 (require 'mm-decode)
 (require 'mm-bodies)
 (require 'mm-encode)
 (require 'mm-decode)

-(eval-when-compile 'cl)
+(require 'mml-sec)
+(eval-when-compile (require 'cl))

 
 (eval-and-compile
   (autoload 'message-make-message-id "message")
 
 (eval-and-compile
   (autoload 'message-make-message-id "message")

@@ -72,15 +73,6 @@ unknown encoding; `use-ascii': always use ASCII for those characters
 with unknown encoding; `multipart': always send messages with more than
 one charsets.")
 
 with unknown encoding; `multipart': always send messages with more than
 one charsets.")
 

-(defvar mml-generate-mime-preprocess-function nil
-  "A function called before generating a mime part.
-The function is called with one parameter, which is the part to be 
-generated.")
-
-(defvar mml-generate-mime-postprocess-function nil
-  "A function called after generating a mime part.
-The function is called with one parameter, which is the generated part.")
-

 (defvar mml-generate-default-type "text/plain")
 
 (defvar mml-buffer-list nil)
 (defvar mml-generate-default-type "text/plain")
 
 (defvar mml-buffer-list nil)

@@ -126,16 +118,13 @@ The function is called with one parameter, which is the generated part.")
                warn t))
        (setq raw (cdr (assq 'raw tag))
              point (point)
                warn t))
        (setq raw (cdr (assq 'raw tag))
              point (point)

-             contents (if raw
-                          (mm-with-unibyte-current-buffer
-                            (mml-read-part (eq 'mml (car tag))))
-                        (mml-read-part (eq 'mml (car tag))))
+             contents (mml-read-part (eq 'mml (car tag)))

              charsets (if raw nil 
                         (mm-find-mime-charset-region point (point))))
        (when (and (not raw) (memq nil charsets))
          (if (or (memq 'unknown-encoding mml-confirmation-set)
                  (y-or-n-p
              charsets (if raw nil 
                         (mm-find-mime-charset-region point (point))))
        (when (and (not raw) (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?"))
+                  "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?")))
              (if (setq use-ascii 
                        (or (memq 'use-ascii mml-confirmation-set)
                            (y-or-n-p "Use ASCII as charset?")))

@@ -230,7 +219,7 @@ The function is called with one parameter, which is the generated part.")
     (setq name (buffer-substring-no-properties
                (point) (progn (forward-sexp 1) (point))))
     (skip-chars-forward " \t\n")
     (setq name (buffer-substring-no-properties
                (point) (progn (forward-sexp 1) (point))))
     (skip-chars-forward " \t\n")

-    (while (not (looking-at ">"))
+    (while (not (looking-at ">[ \t]*\n?"))

       (setq elem (buffer-substring-no-properties
                  (point) (progn (forward-sexp 1) (point))))
       (skip-chars-forward "= \t\n")
       (setq elem (buffer-substring-no-properties
                  (point) (progn (forward-sexp 1) (point))))
       (skip-chars-forward "= \t\n")

@@ -240,8 +229,9 @@ The function is called with one parameter, which is the generated part.")
        (setq val (match-string 1 val)))
       (push (cons (intern elem) val) contents)
       (skip-chars-forward " \t\n"))
        (setq val (match-string 1 val)))
       (push (cons (intern elem) val) contents)
       (skip-chars-forward " \t\n"))

-    (forward-char 1)
-    (skip-chars-forward " \t\n")
+    (goto-char (match-end 0))
+    ;; Don't skip the leading space.
+    ;;(skip-chars-forward " \t\n")

     (cons (intern name) (nreverse contents))))
 
 (defun mml-read-part (&optional mml)
     (cons (intern name) (nreverse contents))))
 
 (defun mml-read-part (&optional mml)

@@ -290,125 +280,143 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
        (buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)
        (buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)

-  (save-restriction
-    (narrow-to-region (point) (point))
-    (if mml-generate-mime-preprocess-function
-       (funcall mml-generate-mime-preprocess-function cont))
-    (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"))
-       (if (and (not raw)
-                (member (car (split-string type "/")) '("text" "message")))
-           (with-temp-buffer
+  (let ((mm-use-ultra-safe-encoding 
+        (or mm-use-ultra-safe-encoding (assq 'sign cont))))
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (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"))
+         (if (and (not raw)
+                  (member (car (split-string type "/")) '("text" "message")))
+             (with-temp-buffer
+               (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")))
+                 (mm-insert-file-contents filename))
+                ((eq 'mml (car cont))
+                 (insert (cdr (assq 'contents cont))))
+                (t
+                 (save-restriction
+                   (narrow-to-region (point) (point))
+                   (insert (cdr (assq 'contents cont)))
+                   ;; Remove quotes from quoted tags.
+                   (goto-char (point-min))
+                   (while (re-search-forward
+                           "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t)
+                     (delete-region (+ (match-beginning 0) 2)
+                                    (+ (match-beginning 0) 3))))))
+               (cond 
+                ((eq (car cont) 'mml)
+                 (let ((mml-boundary (funcall mml-boundary-function
+                                              (incf mml-multipart-number)))
+                       (mml-generate-default-type "text/plain"))
+                   (mml-to-mime))
+                 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
+                   ;; ignore 0x1b, it is part of iso-2022-jp
+                   (setq encoding (mm-body-7-or-8))))
+                ((string= (car (split-string type "/")) "message")
+                 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
+                   ;; ignore 0x1b, it is part of iso-2022-jp
+                   (setq encoding (mm-body-7-or-8))))
+                (t 
+                 (setq charset (mm-encode-body))
+                 (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))))
               ((and (setq filename (cdr (assq 'filename cont)))
                     (not (equal (cdr (assq 'nofile cont)) "yes")))
              (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")))

-               (mm-insert-file-contents filename))
-              ((eq 'mml (car cont))
-               (insert (cdr (assq 'contents cont))))
+               (let ((coding-system-for-read mm-binary-coding-system))
+                 (mm-insert-file-contents filename nil nil nil nil t)))

               (t
               (t

-               (save-restriction
-                 (narrow-to-region (point) (point))
-                 (insert (cdr (assq 'contents cont)))
-                 ;; Remove quotes from quoted tags.
-                 (goto-char (point-min))
-                 (while (re-search-forward
-                         "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t)
-                   (delete-region (+ (match-beginning 0) 2)
-                                  (+ (match-beginning 0) 3))))))
-             (cond 
-              ((eq (car cont) 'mml)
-               (let ((mml-boundary (funcall mml-boundary-function
-                                            (incf mml-multipart-number)))
-                     (mml-generate-default-type "text/plain"))
-                 (mml-to-mime))
-               (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
-                 ;; ignore 0x1b, it is part of iso-2022-jp
-                 (setq encoding (mm-body-7-or-8))))
-              ((string= (car (split-string type "/")) "message")
-               (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
-                 ;; ignore 0x1b, it is part of iso-2022-jp
-                 (setq encoding (mm-body-7-or-8))))
-              (t 
-               (setq charset (mm-encode-body))
-               (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))))
-            ((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)
-                 coded (buffer-string))))
-       (mml-insert-mime-headers cont type charset encoding)
-       (insert "\n")
-       (mm-with-unibyte-current-buffer
-         (insert coded))))
-     ((eq (car cont) 'external)
-      (insert "Content-Type: message/external-body")
-      (let ((parameters (mml-parameter-string
-                        cont '(expiration size permission)))
-           (name (cdr (assq 'name cont))))
-       (when name
-         (setq name (mml-parse-file-name name))
-         (if (stringp name)
+               (insert (cdr (assq 'contents cont)))))
+             (setq encoding (mm-encode-buffer type)
+                   coded (buffer-string))))
+         (mml-insert-mime-headers cont type charset encoding)
+         (insert "\n")
+         (insert coded)))
+       ((eq (car cont) 'external)
+       (insert "Content-Type: message/external-body")
+       (let ((parameters (mml-parameter-string
+                          cont '(expiration size permission)))
+             (name (cdr (assq 'name cont)))
+             (url (cdr (assq 'url cont))))
+         (when name
+           (setq name (mml-parse-file-name name))
+           (if (stringp name)
+               (mml-insert-parameter
+                (mail-header-encode-parameter "name" name)
+                "access-type=local-file")

              (mml-insert-parameter
              (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))))
+              (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 url

            (mml-insert-parameter
            (mml-insert-parameter

-            (concat "access-type="
-                    (if (member (nth 0 name) '("ftp@" "anonymous@"))
-                        "anon-ftp"
-                      "ftp")))))      
-       (when 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")
-      (insert "Content-Transfer-Encoding: "
-             (or (cdr (assq 'encoding cont)) "binary"))
-      (insert "\n\n")
-      (insert (or (cdr (assq 'contents cont))))
-      (insert "\n"))
-     ((eq (car cont) 'multipart)
-      (let* ((type (or (cdr (assq 'type cont)) "mixed"))
-            (mml-generate-default-type (if (equal type "digest")
-                                           "message/rfc822"
-                                         "text/plain"))
-            (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))
-           ;; Skip `multipart' and `type' elements.
-           (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)))
-    (if mml-generate-mime-postprocess-function
-       (funcall mml-generate-mime-postprocess-function cont))))
+            (mail-header-encode-parameter "url" url)
+            "access-type=url"))
+         (when 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")
+       (insert "Content-Transfer-Encoding: "
+               (or (cdr (assq 'encoding cont)) "binary"))
+       (insert "\n\n")
+       (insert (or (cdr (assq 'contents cont))))
+       (insert "\n"))
+       ((eq (car cont) 'multipart)
+       (let* ((type (or (cdr (assq 'type cont)) "mixed"))
+              (mml-generate-default-type (if (equal type "digest")
+                                             "message/rfc822"
+                                           "text/plain"))
+              (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))
+             ;; Skip `multipart' and `type' elements.
+             (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)))
+      (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))
+           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))))))

 
 (defun mml-compute-boundary (cont)
   "Return a unique boundary that does not exist in CONT."
 
 (defun mml-compute-boundary (cont)
   "Return a unique boundary that does not exist in CONT."

@@ -632,8 +640,14 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 ;;;
 
 (defvar mml-mode-map
 ;;;
 
 (defvar mml-mode-map

-  (let ((map (make-sparse-keymap))
+  (let ((sign (make-sparse-keymap))
+       (encrypt (make-sparse-keymap))
+       (map (make-sparse-keymap))

        (main (make-sparse-keymap)))
        (main (make-sparse-keymap)))

+    (define-key sign "p" 'mml-secure-sign-pgpmime)
+    (define-key sign "s" 'mml-secure-sign-smime)
+    (define-key encrypt "p" 'mml-secure-encrypt-pgpmime)
+    (define-key encrypt "s" 'mml-secure-encrypt-smime)

     (define-key map "f" 'mml-attach-file)
     (define-key map "b" 'mml-attach-buffer)
     (define-key map "e" 'mml-attach-external)
     (define-key map "f" 'mml-attach-file)
     (define-key map "b" 'mml-attach-buffer)
     (define-key map "e" 'mml-attach-external)

@@ -642,6 +656,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
     (define-key map "p" 'mml-insert-part)
     (define-key map "v" 'mml-validate)
     (define-key map "P" 'mml-preview)
     (define-key map "p" 'mml-insert-part)
     (define-key map "v" 'mml-validate)
     (define-key map "P" 'mml-preview)

+    (define-key map "s" sign)
+    (define-key map "c" encrypt)

     ;;(define-key map "n" 'mml-narrow-to-part)
     (define-key main "\M-m" map)
     main))
     ;;(define-key map "n" 'mml-narrow-to-part)
     (define-key main "\M-m" map)
     main))

@@ -656,6 +672,13 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
    ("Insert"
     ["Multipart" mml-insert-multipart t]
     ["Part" mml-insert-part t])
    ("Insert"
     ["Multipart" mml-insert-multipart t]
     ["Part" mml-insert-part t])

+   ("Security"
+    ("Sign"
+     ["PGP/MIME" mml-secure-sign-pgpmime t]
+     ["S/MIME" mml-secure-sign-smime t])
+    ("Encrypt"
+     ["PGP/MIME" mml-secure-encrypt-pgpmime t]
+     ["S/MIME" mml-secure-encrypt-smime t]))

    ;;["Narrow" mml-narrow-to-part t]
    ["Quote" mml-quote-region t]
    ["Validate" mml-validate t]
    ;;["Narrow" mml-narrow-to-part t]
    ["Quote" mml-quote-region t]
    ["Validate" mml-validate t]

@@ -669,17 +692,12 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 
 \\{mml-mode-map}"
   (interactive "P")
 
 \\{mml-mode-map}"
   (interactive "P")

-  (if (not (set (make-local-variable 'mml-mode)
-               (if (null arg) (not mml-mode)
-                 (> (prefix-numeric-value arg) 0))))
-      nil
-    (set (make-local-variable 'mml-mode) t)
-    (unless (assq 'mml-mode minor-mode-alist)
-      (push `(mml-mode " MML") minor-mode-alist))
-    (unless (assq 'mml-mode minor-mode-map-alist)
-      (push (cons 'mml-mode mml-mode-map)
-           minor-mode-map-alist)))
-  (run-hooks 'mml-mode-hook))
+  (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)
+    (easy-menu-add mml-menu mml-mode-map)
+    (run-hooks 'mml-mode-hook)))

 
 ;;;
 ;;; Helper functions for reading MIME stuff from the minibuffer and
 
 ;;;
 ;;; Helper functions for reading MIME stuff from the minibuffer and

@@ -708,25 +726,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                      "application/octet-stream"))
         (string (completing-read
                  (format "Content type (default %s): " default)
                      "application/octet-stream"))
         (string (completing-read
                  (format "Content type (default %s): " default)

-                 (mapcar
-                  'list
-                  (mm-delete-duplicates
-                   (nconc
-                    (mapcar 'cdr 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))))))))
+                 (mapcar 'list (mailcap-mime-types)))))

     (if (not (equal string ""))
        string
       default)))
     (if (not (equal string ""))
        string
       default)))

@@ -837,12 +837,14 @@ TYPE is the MIME type to use."
 If RAW, don't highlight the article."
   (interactive "P")
   (let ((buf (current-buffer))
 If RAW, don't highlight the article."
   (interactive "P")
   (let ((buf (current-buffer))

+       (message-options message-options)

        (message-posting-charset (or (gnus-setup-posting-charset 
                                      (save-restriction
                                        (message-narrow-to-headers-or-head)
                                        (message-fetch-field "Newsgroups")))
                                     message-posting-charset)))
        (message-posting-charset (or (gnus-setup-posting-charset 
                                      (save-restriction
                                        (message-narrow-to-headers-or-head)
                                        (message-fetch-field "Newsgroups")))
                                     message-posting-charset)))

-    (switch-to-buffer (get-buffer-create 
+    (message-options-set-recipient)
+    (switch-to-buffer (generate-new-buffer

                       (concat (if raw "*Raw MIME preview of "
                                 "*MIME preview of ") (buffer-name))))
     (erase-buffer)
                       (concat (if raw "*Raw MIME preview of "
                                 "*MIME preview of ") (buffer-name))))
     (erase-buffer)

@@ -852,7 +854,12 @@ If RAW, don't highlight the article."
        (replace-match "\n"))
     (mml-to-mime)
     (if raw
        (replace-match "\n"))
     (mml-to-mime)
     (if raw

-       (mm-disable-multibyte)
+       (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"))
       (let ((gnus-newsgroup-charset (car message-posting-charset)))
        (run-hooks 'gnus-article-decode-hook)
        (let ((gnus-newsgroup-name "dummy"))