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

[gnus] / lisp / mml-smime.el

diff --git a/lisp/mml-smime.el b/lisp/mml-smime.el
index 82d13df..9d9d941 100644 (file)
--- a/lisp/mml-smime.el
+++ b/lisp/mml-smime.el
@@ -1,5 +1,7 @@
 ;;; mml-smime.el --- S/MIME support for MML
-;; Copyright (c) 2000, 2001, 2003 Free Software Foundation, Inc.
+
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
+;;   2005, 2006 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: Gnus, MIME, S/MIME, MML
@@ -18,22 +20,28 @@
 
 ;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 
 ;;; Code:
 
+(eval-when-compile (require 'cl))
+
 (require 'smime)
 (require 'mm-decode)
 (autoload 'message-narrow-to-headers "message")
+(autoload 'message-fetch-field "message")
 
 (defun mml-smime-sign (cont)
   (when (null smime-keys)
     (customize-variable 'smime-keys)
     (error "No S/MIME keys configured, use customize to add your key"))
   (smime-sign-buffer (cdr (assq 'keyfile cont)))
+  (goto-char (point-min))
+  (while (search-forward "\r\n" nil t)
+    (replace-match "\n" t t))
   (goto-char (point-max)))
 
 (defun mml-smime-encrypt (cont)
@@ -46,7 +54,7 @@
       (if (not (and (not (file-exists-p tmp))
                    (get-buffer tmp)))
          (push tmp certfiles)
-       (setq file (mm-make-temp-file (expand-file-name "mml." 
+       (setq file (mm-make-temp-file (expand-file-name "mml."
                                                        mm-tmp-directory)))
        (with-current-buffer tmp
          (write-region (point-min) (point-max) file))
@@ -71,7 +79,10 @@
   (list 'keyfile
        (if (= (length smime-keys) 1)
            (cadar smime-keys)
-         (or (let ((from (cadr (funcall gnus-extract-address-components
+         (or (let ((from (cadr (funcall (if (boundp
+                                             'gnus-extract-address-components)
+                                            gnus-extract-address-components
+                                          'mail-extract-address-components)
                                         (or (save-excursion
                                               (save-restriction
                                                 (message-narrow-to-headers)
@@ -97,7 +108,10 @@
        (while (not result)
          (setq who (read-from-minibuffer
                     (format "%sLookup certificate for: " (or bad ""))
-                    (cadr (funcall gnus-extract-address-components
+                    (cadr (funcall (if (boundp
+                                        'gnus-extract-address-components)
+                                       gnus-extract-address-components
+                                     'mail-extract-address-components)
                                    (or (save-excursion
                                          (save-restriction
                                            (message-narrow-to-headers)
@@ -109,16 +123,36 @@
       (quit))
     result))
 
+(defun mml-smime-get-ldap-cert ()
+  ;; todo: deal with comma separated multiple recipients
+  (let (result who bad cert)
+    (condition-case ()
+       (while (not result)
+         (setq who (read-from-minibuffer
+                    (format "%sLookup certificate for: " (or bad ""))
+                    (cadr (funcall gnus-extract-address-components
+                                   (or (save-excursion
+                                         (save-restriction
+                                           (message-narrow-to-headers)
+                                           (message-fetch-field "to")))
+                                       "")))))
+         (if (setq cert (smime-cert-by-ldap who))
+             (setq result (list 'certfile (buffer-name cert)))
+           (setq bad (format "`%s' not found. " who))))
+      (quit))
+    result))
+
 (defun mml-smime-encrypt-query ()
-  ;; todo: add ldap support (xemacs ldap api?)
   ;; todo: try dns/ldap automatically first, before prompting user
   (let (certs done)
     (while (not done)
       (ecase (read (gnus-completing-read-with-default
-                   "dns" "Fetch certificate from"
-                   '(("dns") ("file")) nil t))
+                   "ldap" "Fetch certificate from"
+                   '(("dns") ("ldap") ("file")) nil t))
        (dns (setq certs (append certs
                                 (mml-smime-get-dns-cert))))
+       (ldap (setq certs (append certs
+                                 (mml-smime-get-ldap-cert))))
        (file (setq certs (append certs
                                  (mml-smime-get-file-cert)))))
       (setq done (not (y-or-n-p "Add more recipients? "))))
@@ -194,4 +228,5 @@
 
 (provide 'mml-smime)
 
+;;; arch-tag: f1bf94d4-f2cd-4c6f-b059-ad69492817e2
 ;;; mml-smime.el ends here