Update Gnus to No Gnus 0.7 from the Gnus CVS trunk

Revision: emacs@sv.gnu.org/emacs--devo--0--patch-911

1 files changed, 200 insertions, 2 deletions

diff --git a/lisp/gnus/mml1991.el b/lisp/gnus/mml1991.el
index 104fb9cfaa3..f6d2dcc7ad5 100644
--- a/lisp/gnus/mml1991.el
+++ b/lisp/gnus/mml1991.el
@@ -3,7 +3,7 @@
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
-;; Author: Sascha Lüdecke <sascha@meta-x.de>,
+;; Author: Sascha Ldecke <sascha@meta-x.de>,
 ;;	Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
 ;; Keywords PGP
 
@@ -32,6 +32,8 @@
   (require 'cl)
   (require 'mm-util))
 
+(require 'mml-sec)
+
 (defvar mc-pgp-always-sign)
 
 (autoload 'quoted-printable-decode-region "qp")
@@ -46,9 +48,28 @@
     (gpg mml1991-gpg-sign
 	 mml1991-gpg-encrypt)
     (pgg mml1991-pgg-sign
-	 mml1991-pgg-encrypt))
+	 mml1991-pgg-encrypt)
+    (epg mml1991-epg-sign
+	 mml1991-epg-encrypt))
   "Alist of PGP functions.")
 
+(defvar mml1991-verbose mml-secure-verbose
+  "If non-nil, ask the user about the current operation more verbosely.")
+
+(defvar mml1991-cache-passphrase mml-secure-cache-passphrase
+  "If t, cache passphrase.")
+
+(defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
+  "How many seconds the passphrase is cached.
+Whether the passphrase is cached at all is controlled by
+`mml1991-cache-passphrase'.")
+
+(defvar mml1991-signers nil
+  "A list of your own key ID which will be used to sign a message.")
+
+(defvar mml1991-encrypt-to-self nil
+  "If t, add your own key ID to recipient list when encryption.")
+
 ;;; mailcrypt wrapper
 
 (eval-and-compile
@@ -290,6 +311,183 @@
   (insert-buffer-substring pgg-output-buffer)
   t)
 
+;; epg wrapper
+
+(eval-and-compile
+  (autoload 'epg-make-context "epg"))
+
+(eval-when-compile
+  (defvar epg-user-id-alist)
+  (autoload 'epg-passphrase-callback-function "epg")
+  (autoload 'epa-select-keys "epa")
+  (autoload 'epg-list-keys "epg")
+  (autoload 'epg-context-set-armor "epg")
+  (autoload 'epg-context-set-textmode "epg")
+  (autoload 'epg-context-set-signers "epg")
+  (autoload 'epg-context-set-passphrase-callback "epg")
+  (autoload 'epg-sign-string "epg")
+  (autoload 'epg-encrypt-string "epg")
+  (autoload 'epg-configuration "epg-config")
+  (autoload 'epg-expand-group "epg-config"))
+
+(eval-when-compile
+  (defvar password-cache-expiry)
+  (autoload 'password-read "password")
+  (autoload 'password-cache-add "password")
+  (autoload 'password-cache-remove "password"))
+
+(defvar mml1991-epg-secret-key-id-list nil)
+
+(defun mml1991-epg-passphrase-callback (context key-id ignore)
+  (if (eq key-id 'SYM)
+      (epg-passphrase-callback-function context key-id nil)
+    (let* ((entry (assoc key-id epg-user-id-alist))
+	   (passphrase
+	    (password-read
+	     (format "GnuPG passphrase for %s: "
+		     (if entry
+			 (cdr entry)
+		       key-id))
+	     (if (eq key-id 'PIN)
+		 "PIN"
+	       key-id))))
+      (when passphrase
+	(let ((password-cache-expiry mml1991-passphrase-cache-expiry))
+	  (password-cache-add key-id passphrase))
+	(setq mml1991-epg-secret-key-id-list
+	      (cons key-id mml1991-epg-secret-key-id-list))
+	(copy-sequence passphrase)))))
+
+(defun mml1991-epg-sign (cont)
+  (let ((context (epg-make-context))
+	headers cte signers signature)
+    (if mml1991-verbose
+	(setq signers (epa-select-keys context "Select keys for signing.
+If no one is selected, default secret key is used.  "
+				       mml1991-signers t))
+      (if mml1991-signers
+	  (setq signers (mapcar (lambda (name)
+				  (car (epg-list-keys context name t)))
+				mml1991-signers))))
+    (epg-context-set-armor context t)
+    (epg-context-set-textmode context t)
+    (epg-context-set-signers context signers)
+    (if mml1991-cache-passphrase
+	(epg-context-set-passphrase-callback
+	 context
+	 #'mml1991-epg-passphrase-callback))
+    ;; Don't sign headers.
+    (goto-char (point-min))
+    (when (re-search-forward "^$" nil t)
+      (setq headers (buffer-substring (point-min) (point)))
+      (save-restriction
+	(narrow-to-region (point-min) (point))
+	(setq cte (mail-fetch-field "content-transfer-encoding")))
+      (forward-line 1)
+      (delete-region (point-min) (point))
+      (when cte
+	(setq cte (intern (downcase cte)))
+	(mm-decode-content-transfer-encoding cte)))
+    (condition-case error
+	(setq signature (epg-sign-string context (buffer-string) 'clear)
+	      mml1991-epg-secret-key-id-list nil)
+      (error
+       (while mml1991-epg-secret-key-id-list
+	 (password-cache-remove (car mml1991-epg-secret-key-id-list))
+	 (setq mml1991-epg-secret-key-id-list
+	       (cdr mml1991-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (delete-region (point-min) (point-max))
+    (mm-with-unibyte-current-buffer
+      (insert signature)
+      (goto-char (point-min))
+      (while (re-search-forward "\r+$" nil t)
+	(replace-match "" t t))
+      (when cte
+	(mm-encode-content-transfer-encoding cte))
+      (goto-char (point-min))
+      (when headers
+	(insert headers))
+      (insert "\n"))
+    t))
+
+(defun mml1991-epg-encrypt (cont &optional sign)
+  (goto-char (point-min))
+  (when (re-search-forward "^$" nil t)
+    (let ((cte (save-restriction
+		 (narrow-to-region (point-min) (point))
+		 (mail-fetch-field "content-transfer-encoding"))))
+      ;; Strip MIME headers since it will be ASCII armoured.
+      (forward-line 1)
+      (delete-region (point-min) (point))
+      (when cte
+	(mm-decode-content-transfer-encoding (intern (downcase cte))))))
+  (let ((context (epg-make-context))
+	(recipients
+	 (if (message-options-get 'message-recipients)
+	     (split-string
+	      (message-options-get 'message-recipients)
+	      "[ \f\t\n\r\v,]+")))
+	cipher signers config)
+    ;; We should remove this check if epg-0.0.6 is released.
+    (if (and (condition-case nil
+		 (require 'epg-config)
+	       (error))
+	     (functionp #'epg-expand-group))
+	(setq config (epg-configuration)
+	      recipients
+	      (apply #'nconc
+		     (mapcar (lambda (recipient)
+			       (or (epg-expand-group config recipient)
+				   (list recipient)))
+			     recipients))))
+    (if mml1991-verbose
+	(setq recipients
+	      (epa-select-keys context "Select recipients for encryption.
+If no one is selected, symmetric encryption will be performed.  "
+			       recipients))
+      (setq recipients
+	    (delq nil (mapcar (lambda (name)
+				(car (epg-list-keys context name)))
+			      recipients))))
+    (if mml1991-encrypt-to-self
+	(if mml1991-signers
+	    (setq recipients
+		  (nconc recipients
+			 (mapcar (lambda (name)
+				   (car (epg-list-keys context name)))
+				 mml1991-signers)))
+	  (error "mml1991-signers not set")))
+    (when sign
+      (if mml1991-verbose
+	  (setq signers (epa-select-keys context "Select keys for signing.
+If no one is selected, default secret key is used.  "
+					 mml1991-signers t))
+	(if mml1991-signers
+	    (setq signers (mapcar (lambda (name)
+				    (car (epg-list-keys context name t)))
+				  mml1991-signers))))
+      (epg-context-set-signers context signers))
+    (epg-context-set-armor context t)
+    (epg-context-set-textmode context t)
+    (if mml1991-cache-passphrase
+	(epg-context-set-passphrase-callback
+	 context
+	 #'mml1991-epg-passphrase-callback))
+    (condition-case error
+	(setq cipher
+	      (epg-encrypt-string context (buffer-string) recipients sign)
+	      mml1991-epg-secret-key-id-list nil)
+      (error
+       (while mml1991-epg-secret-key-id-list
+	 (password-cache-remove (car mml1991-epg-secret-key-id-list))
+	 (setq mml1991-epg-secret-key-id-list
+	       (cdr mml1991-epg-secret-key-id-list)))
+       (signal (car error) (cdr error))))
+    (delete-region (point-min) (point-max))
+    (insert "\n" cipher))
+  t)
+
 ;;;###autoload
 (defun mml1991-encrypt (cont &optional sign)
   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))