[Emacs-diffs] Changes to emacs/lisp/gnus/mml1991.el,v

[Miles Bader]

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Changes by:     Miles Bader <miles>     07/10/28 09:18:40

Index: lisp/gnus/mml1991.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/mml1991.el,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -b -r1.12 -r1.13
--- lisp/gnus/mml1991.el        26 Jul 2007 05:27:02 -0000      1.12
+++ lisp/gnus/mml1991.el        28 Oct 2007 09:18:28 -0000      1.13
@@ -3,7 +3,7 @@
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
 ;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
-;; Author: Sascha Lüdecke <address@hidden>,
+;; Author: Sascha Ldecke <address@hidden>,
 ;;     Simon Josefsson <address@hidden> (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))))