gnus-notifications: add actions support

[gnus] / lisp / mml.el

diff --git a/lisp/mml.el b/lisp/mml.el
index cf592ac..cc1aedf 100644 (file)
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,31 +1,28 @@
 ;;; mml.el --- A package for parsing and validating MML documents
 
 ;;; mml.el --- A package for parsing and validating MML documents
 

-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2012  Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
 
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
 

-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify

 ;; it under the terms of the GNU General Public License as published by
 ;; it under the terms of the GNU General Public License as published by

-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.

 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of

-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.         See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 ;;; Code:
 
 
 ;;; Commentary:
 
 ;;; Code:
 

-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.

 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 
 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 


@@ -35,17 +32,20 @@
 (require 'mm-decode)
 (require 'mml-sec)
 (eval-when-compile (require 'cl))
 (require 'mm-decode)
 (require 'mml-sec)
 (eval-when-compile (require 'cl))

-
-(eval-and-compile
-  (autoload 'message-make-message-id "message")
-  (autoload 'gnus-setup-posting-charset "gnus-msg")
-  (autoload 'gnus-make-local-hook "gnus-util")
-  (autoload 'message-fetch-field "message")
-  (autoload 'message-mark-active-p "message")
-  (autoload 'message-info "message")
-  (autoload 'fill-flowed-encode "flow-fill")
-  (autoload 'message-posting-charset "message")
-  (autoload 'dnd-get-local-file-name "dnd"))
+(eval-when-compile
+  (when (featurep 'xemacs)
+    (require 'easy-mmode))) ; for `define-minor-mode'
+
+(autoload 'message-make-message-id "message")
+(declare-function gnus-setup-posting-charset "gnus-msg" (group))
+(autoload 'gnus-make-local-hook "gnus-util")
+(autoload 'gnus-completing-read "gnus-util")
+(autoload 'message-fetch-field "message")
+(autoload 'message-mark-active-p "message")
+(autoload 'message-info "message")
+(autoload 'fill-flowed-encode "flow-fill")
+(autoload 'message-posting-charset "message")
+(autoload 'dnd-get-local-file-name "dnd")

 
 (autoload 'message-options-set    "message")
 (autoload 'message-narrow-to-head "message")
 
 (autoload 'message-options-set    "message")
 (autoload 'message-narrow-to-head "message")


@@ -120,10 +120,18 @@ match found will be used."
                          ,dispositions))))
   :group 'message)
 
                          ,dispositions))))
   :group 'message)
 

-(defcustom mml-insert-mime-headers-always nil
+(defcustom mml-insert-mime-headers-always t

   "If non-nil, always put Content-Type: text/plain at top of empty parts.
 It is necessary to work against a bug in certain clients."
   "If non-nil, always put Content-Type: text/plain at top of empty parts.
 It is necessary to work against a bug in certain clients."

-  :version "22.1"
+  :version "24.1"
+  :type 'boolean
+  :group 'message)
+
+(defcustom mml-enable-flowed t
+  "If non-nil, enable format=flowed usage when encoding a message.
+This is only performed when filling on text/plain with hard
+newlines in the text."
+  :version "24.1"

   :type 'boolean
   :group 'message)
 
   :type 'boolean
   :group 'message)
 


@@ -228,7 +236,10 @@ part.  This is for the internal use, you should never modify the value.")
        (let* (secure-mode
               (taginfo (mml-read-tag))
               (keyfile (cdr (assq 'keyfile taginfo)))
        (let* (secure-mode
               (taginfo (mml-read-tag))
               (keyfile (cdr (assq 'keyfile taginfo)))

-              (certfile (cdr (assq 'certfile taginfo)))
+              (certfiles (delq nil (mapcar (lambda (tag)
+                                             (if (eq (car-safe tag) 'certfile)
+                                                 (cdr tag)))
+                                           taginfo)))

               (recipients (cdr (assq 'recipients taginfo)))
               (sender (cdr (assq 'sender taginfo)))
               (location (cdr (assq 'tag-location taginfo)))
               (recipients (cdr (assq 'recipients taginfo)))
               (sender (cdr (assq 'sender taginfo)))
               (location (cdr (assq 'tag-location taginfo)))


@@ -254,8 +265,10 @@ part.  This is for the internal use, you should never modify the value.")
                                 ,@tags
                                 ,(if keyfile "keyfile")
                                 ,keyfile
                                 ,@tags
                                 ,(if keyfile "keyfile")
                                 ,keyfile

-                                ,(if certfile "certfile")
-                                ,certfile
+                                ,@(apply #'append
+                                         (mapcar (lambda (certfile)
+                                                   (list "certfile" certfile))
+                                                 certfiles))

                                 ,(if recipients "recipients")
                                 ,recipients
                                 ,(if sender "sender")
                                 ,(if recipients "recipients")
                                 ,recipients
                                 ,(if sender "sender")


@@ -395,8 +408,8 @@ A message part needs to be split into %d charset parts.  Really send? "
       (skip-chars-forward "= \t\n")
       (setq val (buffer-substring-no-properties
                 (point) (progn (forward-sexp 1) (point))))
       (skip-chars-forward "= \t\n")
       (setq val (buffer-substring-no-properties
                 (point) (progn (forward-sexp 1) (point))))

-      (when (string-match "^\"\\(.*\\)\"$" val)
-       (setq val (match-string 1 val)))
+      (when (string-match "\\`\"" val)
+       (setq val (read val))) ;; inverse of prin1 in mml-insert-tag

       (push (cons (intern elem) val) contents)
       (skip-chars-forward " \t\n"))
     (goto-char (match-end 0))
       (push (cons (intern elem) val) contents)
       (skip-chars-forward " \t\n"))
     (goto-char (match-end 0))


@@ -448,20 +461,29 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
 (defvar mml-boundary nil)
 (defvar mml-base-boundary "-=-=")
 (defvar mml-multipart-number 0)
 (defvar mml-boundary nil)
 (defvar mml-base-boundary "-=-=")
 (defvar mml-multipart-number 0)

+(defvar mml-inhibit-compute-boundary nil)

 
 

-(defun mml-generate-mime ()
-  "Generate a MIME message based on the current MML document."
+(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
+be \"related\" or \"alternate\"."

   (let ((cont (mml-parse))
   (let ((cont (mml-parse))

-       (mml-multipart-number mml-multipart-number))
+       (mml-multipart-number mml-multipart-number)
+       (options message-options))

     (if (not cont)
        nil
     (if (not cont)
        nil

-      (mm-with-multibyte-buffer
-       (if (and (consp (car cont))
-                (= (length cont) 1))
-           (mml-generate-mime-1 (car cont))
-         (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
-                                     cont)))
-       (buffer-string)))))
+      (prog1
+         (mm-with-multibyte-buffer
+           (setq message-options options)
+           (if (and (consp (car cont))
+                    (= (length cont) 1))
+               (mml-generate-mime-1 (car cont))
+             (mml-generate-mime-1
+              (nconc (list 'multipart (cons 'type (or multipart-type "mixed")))
+                     cont)))
+           (setq options message-options)
+           (buffer-string))
+       (setq message-options options)))))

 
 (defun mml-generate-mime-1 (cont)
   (let ((mm-use-ultra-safe-encoding
 
 (defun mml-generate-mime-1 (cont)
   (let ((mm-use-ultra-safe-encoding


@@ -485,7 +507,12 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                 (setq charset nil
                       coding nil))
                (charset
                 (setq charset nil
                       coding nil))
                (charset

-                (setq charset (intern (downcase charset)))))
+                ;; The value of `charset' might be a bogus alias that
+                ;; `mm-charset-synonym-alist' provides, like `utf8',
+                ;; so we prefer the MIME charset that Emacs knows for
+                ;; the coding system `coding'.
+                (setq charset (or (mm-coding-system-to-mime-charset coding)
+                                  (intern (downcase charset))))))

          (if (and (not raw)
                   (member (car (split-string type "/")) '("text" "message")))
              (progn
          (if (and (not raw)
                   (member (car (split-string type "/")) '("text" "message")))
              (progn


@@ -506,7 +533,7 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                      ;; Remove quotes from quoted tags.
                      (goto-char (point-min))
                      (while (re-search-forward
                      ;; Remove quotes from quoted tags.
                      (goto-char (point-min))
                      (while (re-search-forward

-                             "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
+                             "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"

                              nil t)
                        (delete-region (+ (match-beginning 0) 2)
                                       (+ (match-beginning 0) 3))))))
                              nil t)
                        (delete-region (+ (match-beginning 0) 2)
                                       (+ (match-beginning 0) 3))))))


@@ -518,7 +545,11 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                          ;; `m-g-d-t' will be bound to "message/rfc822"
                          ;; when encoding an article to be forwarded.
                          (mml-generate-default-type "text/plain"))
                          ;; `m-g-d-t' will be bound to "message/rfc822"
                          ;; when encoding an article to be forwarded.
                          (mml-generate-default-type "text/plain"))

-                     (mml-to-mime))
+                     (mml-to-mime)
+                     ;; Update handle so mml-compute-boundary can
+                     ;; detect collisions with the nested parts.
+                     (unless mml-inhibit-compute-boundary
+                       (setcdr (assoc 'contents cont) (buffer-string))))

                    (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))))
                    (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))))


@@ -532,7 +563,8 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                    ;; in the mml tag or it says "flowed" and there
                    ;; actually are hard newlines in the text.
                    (let (use-hard-newlines)
                    ;; in the mml tag or it says "flowed" and there
                    ;; actually are hard newlines in the text.
                    (let (use-hard-newlines)

-                     (when (and (string= type "text/plain")
+                     (when (and mml-enable-flowed
+                                 (string= type "text/plain")

                                 (not (string= (cdr (assq 'sign cont)) "pgp"))
                                 (or (null (assq 'format cont))
                                     (string= (cdr (assq 'format cont))
                                 (not (string= (cdr (assq 'sign cont)) "pgp"))
                                 (or (null (assq 'format cont))
                                     (string= (cdr (assq 'format cont))


@@ -583,7 +615,9 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
                        (unless raw
                          (setq charset (mm-encode-body charset))))
                    (insert contents)))))
                        (unless raw
                          (setq charset (mm-encode-body charset))))
                    (insert contents)))))

-             (setq encoding (mm-encode-buffer type)
+             (if (setq encoding (cdr (assq 'encoding cont)))
+                 (setq encoding (intern (downcase encoding))))
+             (setq encoding (mm-encode-buffer type encoding)

                    coded (mm-string-as-multibyte (buffer-string))))
            (mml-insert-mime-headers cont type charset encoding nil)
            (insert "\n" coded))))
                    coded (mm-string-as-multibyte (buffer-string))))
            (mml-insert-mime-headers cont type charset encoding nil)
            (insert "\n" coded))))


@@ -686,34 +720,30 @@ If MML is non-nil, return the buffer up till the correspondent mml tag."
   "Return a unique boundary that does not exist in CONT."
   (let ((mml-boundary (funcall mml-boundary-function
                               (incf mml-multipart-number))))
   "Return a unique boundary that does not exist in CONT."
   (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
-                 (mml-compute-boundary-1 cont))))
+    (unless mml-inhibit-compute-boundary
+      ;; This function tries again and again until it has found
+      ;; a unique boundary.
+      (while (not (catch 'not-unique
+                   (mml-compute-boundary-1 cont)))))

     mml-boundary))
 
 (defun mml-compute-boundary-1 (cont)
     mml-boundary))
 
 (defun mml-compute-boundary-1 (cont)

-  (let (filename)
-    (cond
-     ((eq (car cont) 'part)
-      (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 nil nil nil nil t))
-        (t
-         (insert (cdr (assq 'contents cont)))))
-       (goto-char (point-min))
-       (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
-                                nil t)
-         (setq mml-boundary (funcall mml-boundary-function
-                                     (incf mml-multipart-number)))
-         (throw 'not-unique nil))))
-     ((eq (car cont) 'multipart)
-      (mapc 'mml-compute-boundary-1 (cddr cont))))
-    t))
+  (cond
+   ((member (car cont) '(part mml))
+    (mm-with-multibyte-buffer
+      (let ((mml-inhibit-compute-boundary t)
+           (mml-multipart-number 0)
+           mml-sign-alist mml-encrypt-alist)
+       (mml-generate-mime-1 cont))
+      (goto-char (point-min))
+      (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
+                              nil t)
+       (setq mml-boundary (funcall mml-boundary-function
+                                   (incf mml-multipart-number)))
+       (throw 'not-unique nil))))
+   ((eq (car cont) 'multipart)
+    (mapc 'mml-compute-boundary-1 (cddr cont))))
+  t)

 
 (defun mml-make-boundary (number)
   (concat (make-string (% number 60) ?=)
 
 (defun mml-make-boundary (number)
   (concat (make-string (% number 60) ?=)


@@ -873,6 +903,7 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
 (autoload 'message-encode-message-body "message")
 (declare-function message-narrow-to-headers-or-head "message" ())
 
 (autoload 'message-encode-message-body "message")
 (declare-function message-narrow-to-headers-or-head "message" ())
 

+;;;###autoload

 (defun mml-to-mime ()
   "Translate the current buffer from MML to MIME."
   ;; `message-encode-message-body' will insert an encoded Content-Description
 (defun mml-to-mime ()
   "Translate the current buffer from MML to MIME."
   ;; `message-encode-message-body' will insert an encoded Content-Description


@@ -894,12 +925,18 @@ If HANDLES is non-nil, use it instead reparsing the buffer."
     ;; Determine type and stuff.
     (unless (stringp (car handle))
       (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
     ;; Determine type and stuff.
     (unless (stringp (car handle))
       (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))

-       (save-excursion
-         (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
-         (mm-insert-part handle 'no-cache)
-         (if (setq mmlp (equal (mm-handle-media-type handle)
-                               "message/rfc822"))
-             (mime-to-mml)))))
+       (with-current-buffer (setq buffer (mml-generate-new-buffer " *mml*"))
+         (if (eq (mail-content-type-get (mm-handle-type handle) 'charset)
+                 'gnus-decoded)
+             ;; A part that mm-uu dissected from a non-MIME message
+             ;; because of `gnus-article-emulate-mime'.
+             (progn
+