Linux Cubed Series 2: Applications/Linux Cubed Series 2 - Applications.iso/editors/emacs/xemacs/xemacs-1.006/xemacs-1/lib/xemacs-19.13/lisp/packages/mailcrypt.el

Text File | 1995-06-13 | 38.1 KB | 1,145 lines

;; mailcrypt.el v2.4beta, mail encryption with RIPEM and PGP
;; Copyright (C) 1993  Jin Choi <[e-mail]>
;; Any comments or suggestions welcome.
;; Inspired by pgp.el, by Gray Watson <[e-mail]>.

;; LCD Archive Entry:
;; mailcrypt|Jin S Choi|[e-mail]|
;; Encryption/decryption for mail using RIPEM or PGP. Supports RMAIL, VM, mh-e|
;; 13-Jun-1994|2.4beta|~/interfaces/mailcrypt.el.Z|

;;{{{ Licensing
;; This file is intended to be used with GNU Emacs.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program 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
;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
;;}}}

;;{{{ TODO
;; * Interface for view-mode in xemacs has changed, how annoying. Must fix.
;; * Cleanup of temp files is pgp specific. Make more general.
;; * Include support for auto-decryption/verification.
;; * Support X-PGP-SIGNED header used by npgp.el.
;; Not really mailcrypt problems, but...
;; * Fix problem with mh-e not observing value of mail-header-separator.
;;}}}

;;{{{ Change Log
;;{{{ Changes from 1.6:
;; * Decrypting a signed message in RMAIL adds a verified tag to the message.
;; * mc-sign-message takes an optional argument specifying which key to use,
;;   for people who have multiple private keys.
;; * Added mc-{pre,post}-{de,en}cryption-hooks.
;; * Additions to docstrings of the major functions and `mailcrypt-*' aliases
;;   for the same.
;; * Added cleanup for possible temp files left over if a process was
;;   interrupted.
;; * Easier installation instructions.
;; * Lots of little bug fixes from all over. Too many to list
;;   individual credits, but I've tried to include all of them. Thanks
;;   to all who sent them in, especially to John T Kohl who fixed an
;;   especially trying problem.
;; * Another optional argument to mc-insert-public-key that allows the
;;   user to specify which public key to insert when called with a
;;   prefix argument.
;; * Tons of changes from Paul Furnanz <[e-mail]>:
;; 1) Use the itimer package instead of the timer package if it exists.
;;    This makes the password deactivation code work for Lemacs as well
;;    as emacs 19.
;; 2) Fractured the code, so that there is a single function to use
;;    when calling the encryption program.  The new function is
;;    mc-process-region.  The function copies all data to a temporary
;;    buffer, and does the work there.  This way if you do an undo after
;;    an encryption or signing, your password is not visible on the
;;    screen.
;; 3) All process output goes to the *MailCrypt* buffer.  No longer use
;;    a separate buffer for decryption, encryption, verification, ...
;;    This allows the user to always look at the *MailCrypt* buffer to
;;    see what pgp or ripem said.
;; 4) No longer call mc-temp-display.  Use display-buffer if there is a
;;    reason to show the buffer (like an error occured).
;; 5) Try to print more useful messages.
;; 6) If an error occurs on encryption, the message is left unchanged.
;;    No reason to undo.
;;}}}
;;{{{ Changes from 1.5:
;; * Changed mc-temp-display to just dump into a temp buffer, without
;;   any fancy display stuff. Pick up show-temp.el if you liked the
;;   display stuff (or uncomment the old mc-temp-buffer and remove the
;;   new version).
;; * Provided a generic read mode function to call in hooks, like the
;;   generic write mode function that was already there.
;; * Fixed bug in regexp that prevented compilation under recent
;;   versions of FSF emacs.
;; * Narrow to headers when extracting default recipients for encryption
;;   to avoid pulling in recipients of included messages.
;; * Use `fillarray' to overwrite passwords with nulls before deactivation
;;   for increased security.
;; * Load mail-extr.el to get mail-extract-address-components defined.
;; Thanks to Kevin Rodgers <[e-mail]> for the following
;; improvements.
;; * Quoted an unquoted lambda expression that prevented optimized
;;   compilation under emacs 18.
;; * Used `nconc' instead of `append' in various places to save on
;;   garbage collection.
;; * Modified mc-split to run more efficiently.
;;}}}
;;{{{ Changes from 1.4:
;; * Call mail-extract-address-components on the recipients if we guessed
;;   them from the header fields.
;; * If you don't replace a message with its decrypted version, it will now
;;   pop you into a view buffer with the contents of the message.
;; * Added support for mh-e, contributed by Fritz Knabe <[e-mail]>
;; * Fixed bug in snarfing keys from menubar under GNUS.
;; * Fixed RIPEM verification problem, thanks to Sergey Gleizer
;;   <[e-mail]>.
;;}}}
;;{{{ Changes from 1.3:
;; * Temp display function does not barf on F-keys or mouse events.
;;     Thanks to Jonathan Stigelman <[e-mail]>
;; * Lucid emacs menu support provided by William Perry <[e-mail]>
;; * Cited signed messages would interfere with signature
;;    verification; fixed.
;;}}}
;;{{{ Changes from 1.2:
;; * Added menu bar support for emacs 19.
;; * Added GNUS support thanks to Samuel Druker <[e-mail]>.
;;}}}
;;{{{ Changes from 1.1:
;; * Added recipients field to mc-encrypt-message.
;;}}}
;;{{{ Changes from 1.0:
;; * Fixed batchmode bug in decryption, where unsigned messages would return
;;   with exit code of 1.
;;}}}
;;{{{ Changes from 0.3b:
;; * Only set PGPPASSFD when needed, so PGP won't break when used
;;   in shell mode.
;; * Use call-process-region instead of shell-command-on-region in order
;;   to detect exit codes.
;; * Changed mc-temp-display to not use the kill ring.
;; * Bug fixes.
;;}}}
;;{{{ Changes from 0.2b:
;; * Prompts for replacement in mc-rmail-decrypt-message.
;; * Bug fixes.
;;}}}
;;{{{ Changes from 0.1b:
;; * Several bug fixes.
;; Contributed by Jason Merrill <[e-mail]>:
;; * VM mailreader support
;; * Support for addresses with spaces and <>'s in them
;; * Support for using an explicit path for the pgp executable
;; * Key management functions
;; * The ability to avoid some of the prompts when encrypting
;; * Assumes mc-default-scheme unless prefixed
;;}}}

;;}}}

;;{{{ Usage:

;;{{{ Installation:

;; To use, put something like the following elisp into your .emacs file.
;; You may want to set some of the user variables there as well,
;; particularly mc-default-scheme.

;; Currently supported modes are RMAIL, VM, mh-e, and gnus. Check out
;; the section on mode specific functions to see what hooks you can bind to.

;;(autoload 'mc-install-write-mode "mailcrypt" nil t)
;;(autoload 'mc-install-read-mode "mailcrypt" nil t)

;;(add-hook 'mail-mode-hook 'mc-install-write-mode)  ; for writing modes
;;(add-hook 'rmail-mode-hook 'mc-install-read-mode)  ; for reading modes


;; hooks to use:
;; PACKAGE     READ HOOK        WRITE HOOK
;; -------    ---------        ----------
;; rmail:     rmail-mode-hook        mail-mode-hook
;; vm:        vm-mode-hook        mail-mode-hook
;; mh-e:    mh-folder-mode-hook    mh-letter-mode-hook
;; gnus:    gnus-summary-mode-hook    news-reply-mode-hook

;;{{{ Installation functions; you can ignore these.

;;;###autoload
(defun mc-install-write-mode ()
  (if (eq window-system 'x)
      (mc-create-write-menu-bar))
  (local-set-key "\C-ce" 'mc-encrypt-message)
  (local-set-key "\C-cs" 'mc-sign-message)
  (local-set-key "\C-ca" 'mc-insert-public-key))

;;;###autoload
(defun mc-install-read-mode ()
  (let ((decrypt (nth 0 (cdr (assoc major-mode mc-modes-alist))))
    (verify (nth 1 (cdr (assoc major-mode mc-modes-alist))))
    (snarf (nth 2 (cdr (assoc major-mode mc-modes-alist)))))
    (if (not (and decrypt verify))
    (error "Decrypt, verify functions not defined for this major mode."))
    (if (not snarf)
    (setq snarf 'mc-snarf-keys))
    (local-set-key "\C-cd" decrypt)
    (local-set-key "\C-cv" verify)
    (local-set-key "\C-ca" snarf))
  (if (eq window-system 'x)
      (mc-create-read-menu-bar)))
;;}}}

;;}}}
;;{{{ Security Considerations

;; I've tried to write this with security in mind, especially in
;; regard to the passphrase used to encrypt the private key.

;; No passphrase is ever passed by command line or environment
;; variable. The passphrase may be temporarily stored into an elisp
;; variable to allow multiple encryptions/decryptions within a short
;; period of time without having to type it in each time. It will
;; deactivate automatically some time after its last use (default one
;; minute; see `mc-passwd-timeout') if you are running emacs 19. This
;; is to prevent someone from walking up to your computer while you're
;; gone and looking up your passphrase. If you are using an older
;; version of emacs, you can either set mc-passwd-timeout to nil,
;; which disables passphrase cacheing, or manually deactivate your
;; passphrase when you are done with it by typing `M-x mc-deactivate-passwd'.

;; The passphrase may still be visible shortly after entry as lossage
;; (the last 100 characters entered can be displayed by typing
;; `C-h l'). I've taken no steps to deal with this, as I don't think
;; anything *can* be done. If you are the paranoid type, make sure you
;; type at least a hundred keys after entering your passphrase before
;; you leave your emacs unattended.

;; If you are truly security conscious, you should, of course, never
;; leave your computer unattended while you're logged in....

;;}}}
;;{{{ CAVEAT:

;; This code breaks if you have "Verbose=0" in your config.txt for PGP.
;; Thanks to Ciamac Moallemi ([e-mail]) for pointing this out.

;; This was written under emacs v19. Its behavior under older versions
;; of emacs is untested. If something breaks under emacs 18, please
;; feel free to fix it and send me patches.
;;}}}
;;{{{ Note:
;; The funny triple braces you see are used by `folding-mode', a minor
;; mode by Jamie Lokier, available from the elisp archive.
;;}}}

;;}}}


;;{{{ Load some required packages
(require 'comint)
(require 'mail-utils)
(eval-when-compile
  (condition-case nil
      (require 'vm)
    (error nil)))
(require 'mail-extr)

;; Load the timer package if we're running non-Lucid emacs 19,
;; so that (featurep 'timer) returns t later on.
(if (and (string-match "^19" emacs-version)
     (not (string-match "Lucid\\|XEmacs" emacs-version)))
    (require 'timer))

;; mailcrypt packages
;;XEmacs - inline this thing...(require 'mc-pgp)
;; This is the mailcrypt package for PGP.
;;; Place it somewhere in your load path as mc-pgp.el.

;;; ------------------------------------------------------------------------
(defvar mc-pgp-user-id (user-login-name) "*Your PGP user ID.")
(defvar mc-pgp-always-sign nil "*Always sign encrypted PGP messages.")
(defvar mc-pgp-path "pgp" "*The PGP executable.")

(defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----"
  "Text for start of PGP message delimiter.")
(defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----"
  "Text for end of PGP message delimiter.")
(defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----"
  "Text for start of PGP signed messages.")
(defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----"
  "Text for end of PGP signed messages.")
(defconst mc-pgp-key-begin-line "-----BEGIN PGP PUBLIC KEY BLOCK-----"
  "Text for start of PGP public key.")
(defconst mc-pgp-key-end-line "-----END PGP PUBLIC KEY BLOCK-----"
  "Text for end of PGP public key.")
(defconst mc-pgp-error-re "^\\(ERROR\\|WARNING\\):.*"
  "Regular expression matching an error from PGP")
(defconst mc-pgp-sigok-re "^.*Good signature.*"
  "Regular expression matching a PGP signature validation message")
(defconst mc-pgp-newkey-re "\\(No\\|[0-9]\\)+\\s-+new.*"
  "Regular expression matching a PGP signature snarf message")


(defun mc-pgp-encrypt-region (recipients start end)
  (let ((process-environment process-environment)
    (buffer (get-buffer-create mc-buffer-name))
    args signed-p)
    (and mc-encrypt-for-me
     (setq recipients (cons mc-pgp-user-id recipients)))
    (setq args (list "+batchmode" "-feat"))
    (if (or mc-pgp-always-sign (y-or-n-p "Sign the message? "))
    (setq signed-p t
          args (nconc args (list "-su" mc-pgp-user-id))))
    (setq args (nconc args recipients))

    ;; Don't need to ask for the passphrase if not signing.
    (if signed-p
    (setq process-environment
          (cons "PGPPASSFD=0"
            process-environment)))
    (message "Encrypting...")
    (if (not (mc-process-region start end
                (and signed-p "PGP Password: ")
                mc-pgp-path args
                buffer mc-pgp-msg-begin-line t))
    (progn
      (mc-display-buffer buffer)
      (mc-message mc-pgp-error-re buffer "Error while encrypting" t)))))


(defun mc-pgp-decrypt-region (start end)
  ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if
  ;; the encryption succeeded and verified is t if there was a valid signature
  (let ((process-environment
     (cons "PGPPASSFD=0" process-environment))
    (buffer (get-buffer-create mc-buffer-name))
    retval)
    (message "Decrypting...")
    (if (mc-process-region
     start end "PGP Password: "
     mc-pgp-path '("-f")
     buffer
     (and (null buffer-read-only)
          '("^Signature made.*\n" "Just a moment\\.+")))
    (progn
      (if buffer-read-only
          (pop-to-buffer buffer))
      (cons t (mc-message mc-pgp-sigok-re buffer "Decrypted.")))
      (mc-display-buffer buffer)
      (mc-message mc-pgp-error-re buffer "Error decrypting buffer")
      (cons nil nil))))

(defun mc-pgp-sign-region (start end &optional withkey)
  (let ((process-environment (cons "PGPPASSFD=0" process-environment))
    (buffer (get-buffer-create mc-buffer-name))
    (user-id (or withkey mc-pgp-user-id)))
    (message "Signing...")
    (if (not (mc-process-region start end "PGP Password: "
                mc-pgp-path (list "-fast" "+clearsig=on"
                          "+batchmode"
                          "-u" user-id)
                buffer "^Just a moment\\.+"))
    (progn
      (mc-display-buffer buffer)
      (mc-message mc-pgp-error-re buffer "PGP signing failed" t)))))


(defun mc-pgp-verify-region (start end)
  (let ((buffer (get-buffer-create mc-buffer-name)))
    (message "Verifying...")
    (if (mc-process-region start end nil
               mc-pgp-path '("+batchmode" "-f") buffer)
    (prog1
        t
      (mc-message mc-pgp-sigok-re buffer "Good signature"))
      (mc-display-buffer buffer)
      (mc-message mc-pgp-error-re buffer "Error verifying PGP signature")
      nil)))

(defun mc-pgp-insert-public-key (userid)
  (let ((buffer (get-buffer-create mc-buffer-name)))
    (if (not (mc-process-region (point) (point) nil
                mc-pgp-path
                (list "+batchmode" "-kxaf" userid)
                buffer
                mc-pgp-key-begin-line t))
    (mc-message mc-pgp-error-re buffer
            "Error including signature" t))))


(defun mc-pgp-snarf-key (start end)
  (let ((buffer (get-buffer-create mc-buffer-name)))
    (message "Snarfing...")
    (if (mc-process-region start end nil
               mc-pgp-path '("+batchmode" "-kaf")
               buffer)
    (mc-message mc-pgp-newkey-re buffer
            "No new keys found")
      (mc-display-buffer buffer)
      (mc-message mc-pgp-error-re buffer "Error snarfing PGP key" t))))

(defvar mc-scheme-pgp
  (list
   (cons 'encryption-func         'mc-pgp-encrypt-region)
   (cons 'decryption-func        'mc-pgp-decrypt-region)
   (cons 'signing-func        'mc-pgp-sign-region)
   (cons 'verification-func     'mc-pgp-verify-region)
   (cons 'key-insertion-func     'mc-pgp-insert-public-key)
   (cons 'snarf-func        'mc-pgp-snarf-key)
   (cons 'msg-begin-line         mc-pgp-msg-begin-line)
   (cons 'msg-end-line         mc-pgp-msg-end-line)
   (cons 'signed-begin-line     mc-pgp-signed-begin-line)
   (cons 'signed-end-line         mc-pgp-signed-end-line)
   (cons 'key-begin-line         mc-pgp-key-begin-line)
   (cons 'key-end-line         mc-pgp-key-end-line)
   (cons 'user-id    mc-pgp-user-id)))

(provide 'mc-pgp)

;;}}}
;;{{{ User variables.

(defvar mc-default-scheme mc-scheme-pgp "*Default encryption scheme to use.")
(defvar mc-passwd-timeout 60
  "*Time to deactivate password in seconds after a use.
nil or 0 means deactivate immediately.  If the only timer package available
is the 'timer' package, then this can be a string in timer format.")

(defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME")
                 (user-full-name) "*Your RIPEM user ID."))

(defvar mc-always-replace nil "*Decrypt messages in place without prompting.")
(defvar mc-use-default-recipients nil
  "*Assume that the message should be encoded for everyone listed in the To:
and Cc: fields.")
(defvar mc-encrypt-for-me nil
  "*Encrypt all outgoing messages with user's public key.")

(defvar mc-pre-encryption-hook nil
  "*List of hook functions to run immediately before encrypting.")
(defvar mc-post-encryption-hook nil
  "*List of hook functions to run after encrypting.")
(defvar mc-pre-decryption-hook nil
  "*List of hook functions to run immediately before decrypting.")
(defvar mc-post-decryption-hook nil
  "*List of hook functions to run after decrypting.")


;;}}}
;;{{{ Program variables and constants.

(defvar mc-timer nil "Timer object for password deactivation.")

(defvar mc-passwd nil "Your secret key passphrase.")

;; You might consider interposing a program such as below, which
;; refuses to let pgp get hold of a terminal; this makes it work
;; better as a slave process:
;;
;;#include <unistd.h>
;;#include <sys/types.h>
;;#include <sys/wait.h>
;;/*
;; * call setsid() in child
;; * to revoke controlling terminal, then execvp pgp with args.
;; */
;;main(int argc, char *argv[])
;;{
;;    pid_t pid;
;;    int status;
;;    pid = fork();
;;    if (pid == 0) {
;;    /* child */
;;    if (setsid() == -1)
;;        perror("setsid");
;;    execvp("pgp", argv);
;;    perror("cannot execvp pgp");
;;    exit(1);
;;    } else if (pid > 0) {
;;    waitpid(pid, &status, 0);
;;    exit(WEXITSTATUS(status));
;;    } else {
;;    perror("fork");
;;    exit(1);
;;    }
;;}


(defconst mc-buffer-name "*MailCrypt*"
  "Name of temporary buffer for mailcrypt")

(defvar mc-schemes
  (list
   (cons "pgp" mc-scheme-pgp)))

;;}}}
;;{{{ Utility functions.

(defun mc-message-delimiter-positions (start-re end-re &optional begin)
  ;; Returns pair of integers (START . END) that delimit message marked off
  ;; by the regular expressions start-re and end-re. Optional argument BEGIN
  ;; determines where we should start looking from.
  (if (null begin)
      (setq begin (point-min)))
  (goto-char begin)
  (let (start retval bad-re)
    (catch 'notfound
      (save-excursion
    (goto-char (point-min))
    (or (re-search-forward (concat "^" start-re) nil t)
        (throw 'notfound nil))
    (setq start (match-beginning 0))
    (or (re-search-forward (concat "^" end-re "\n") nil t)
        (throw 'notfound nil))
    (cons start (point))))))


(defun mc-split (regexp str)
  "Splits STR into a list of elements which were separated by REGEXP,
stripping initial and trailing whitespace."
  (let ((data (match-data))
    (retval '())
    beg end)
    (unwind-protect
    (progn
      (string-match "[ \t\n]*" str)    ; Will always match at 0
      (setq beg (match-end 0))
      ;; This will break if there are newlines in str XXX
      (setq end (string-match "[ \t\n]*$" str))
      (while (string-match regexp str beg)
        (setq retval
          (cons (substring str beg (match-beginning 0))
            retval))
        (setq beg (match-end 0)))
      (if (not (= (length str) beg)) ; Not end
          (setq retval (cons (substring str beg end) retval)))
      (nreverse retval))
      (store-match-data data))))

(defun mc-temp-display (beg end &optional name)
  (let (tmp)
    (if (not name)
    (setq name mc-buffer-name))
    (if (string-match name "*ERROR*")
    (progn
      (message "mailcrypt: An error occured!  See *ERROR* buffer.")
      (beep)))
    (setq tmp (buffer-substring beg end))
    (delete-region beg end)
    (save-excursion
      (save-window-excursion
    (with-output-to-temp-buffer name
      (princ tmp))))))

;;(defun mc-temp-display (beg end &optional name)
;;  (let (tmp)
;;    (if (not name)
;;    (setq name "*Mailcrypt Temp*"))
;;    (setq tmp (buffer-substring beg end))
;;    (delete-region beg end)
;;    (save-excursion
;;      (set-buffer (generate-new-buffer name))
;;      (insert tmp)
;;      (goto-char (point-min))
;;      (save-window-excursion
;;    (shrink-window-if-larger-than-buffer
;;     (display-buffer (current-buffer)))
;;    (message "Press any key to remove the %s window." name)
;;    (cond ((and (string-match "19\\." emacs-version)
;;            (not (string-match "XEmacs" (emacs-version))))
;;           (read-event))
;;          (t
;;           (read-char)))
;;    (kill-buffer (current-buffer))))))

(defun mc-display-buffer (buffer)
  "Like display-buffer, but always display top of the buffer."
  (save-excursion
    (set-buffer buffer)
    (goto-char (point-min))
    (display-buffer buffer)))

(defun mc-message (msg &optional buffer default iserr)
  ;; returns t if we used msg, nil if we used default
  (let ((retval t))
    (if buffer
    (setq msg
          (save-excursion
        (set-buffer buffer)
        (goto-char (point-min))
        (if (re-search-forward msg nil t)
            (buffer-substring (match-beginning 0) (match-end 0))
          (setq retval nil)
          default))))
    (prog1
    retval
      (if iserr
      (mc-deactivate-passwd))    ; in case error is bad passphrase
      (and msg (message msg)))))

(defun mc-process-region (beg end passwd program args &optional buffer
                  copy keep)
  (if (stringp copy)
      (setq copy (list copy)))
  (let ((oldbuf (current-buffer))
    mybuf result)
    (unwind-protect
    (progn
      (setq mybuf (or buffer (generate-new-buffer " mailcrypt temp")))
      (set-buffer mybuf)
      (erase-buffer)
      (buffer-disable-undo mybuf)
      (if passwd
          (progn
        (insert (mc-activate-passwd passwd) "\n")
        (or mc-passwd-timeout (mc-deactivate-passwd))))
      (insert-buffer-substring oldbuf beg end)

      ;; Catch a quit signal so we can clean up any
      ;; temp files lying around if the user nukes us.
      (setq result (condition-case nil
               (apply 'call-process-region
                  (nconc (list (point-min) (point-max)
                           program
                           t t nil)
                     args))
             (quit
              ;; don't let the user interrupt the cleanup
              (let ((inhibit-quit t))
                (shell-command "rm -f pgptemp.*")
                (setq quit-flag nil)
                "Stopped at user request"))))
      ;; CRNL -> NL
      (goto-char (point-min))
      (while (search-forward "\r\n" nil t)
        (forward-char -1)
        (delete-char -1))

      (cond ((stringp result)    ;process terminated somehow
         (message "Mailcrypt process died abnormally: '%s'" result)
         (sit-for 2)
         nil)
        ((zerop result)
         (prog1
             t
           (if copy
               (let (start)
             (goto-char (point-min))
             (and (listp copy)
                  (let ((c copy))
                (while (and c
                        (null (re-search-forward (car c)
                                     nil t)))
                  (setq c (cdr c)))
                c)
                  keep (goto-char (match-beginning 0)))
             (setq start (point))
             (save-excursion
               (set-buffer oldbuf)
               (delete-region beg end)
               (goto-char beg)
               (insert-buffer-substring mybuf start))
             (delete-region start (point-max))))))
        (t
         nil)))
      (set-buffer oldbuf)
      (and mybuf (or (null result) (null buffer)) (kill-buffer mybuf)))))

;;}}}
;;{{{ Passphrase management

(defun mc-activate-passwd (prompt)
  (cond ((featurep 'itimer)
     (if mc-timer (delete-itimer mc-timer))
     (setq mc-timer (if mc-passwd-timeout
                (start-itimer "mc-itimer" 'mc-deactivate-passwd
                      mc-passwd-timeout))))
    ((featurep 'timer)
     (let ((string-time (if (integerp mc-passwd-timeout)
                (format "%d sec" mc-passwd-timeout)
                  mc-passwd-timeout)))
       (if mc-timer (cancel-timer mc-timer))
       (setq mc-timer (if string-time
                  (run-at-time string-time
                       nil 'mc-deactivate-passwd)
                nil)))))
  (if (not mc-passwd)
      (setq mc-passwd (comint-read-noecho prompt)))
  mc-passwd)

;;;###autoload
(defun mc-deactivate-passwd ()
  "*Deactivates the passphrase."
  (interactive)
  (and mc-timer (fboundp 'cancel-timer) (cancel-timer mc-timer))
  (and (stringp mc-passwd) (fillarray mc-passwd 0))
  (setq mc-passwd nil)
  (message "password deactivated"))

;;}}}
;;{{{ Encryption

(defun mc-cleanup-recipient-headers (str)
  ;; Takes a comma separated string of recipients to encrypt for and,
  ;; assuming they were possibly extracted from the headers of a reply,
  ;; returns a list of the address components.
  (mapcar (function
       (lambda (x)
         (car (cdr (mail-extract-address-components x)))))
      (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" str)))

;;;###autoload
(defun mc-encrypt-message (&optional recipients scheme)
  "*Encrypt the message to RECIPIENTS using the given encryption SCHEME.
RECIPIENTS is a comma separated string. If SCHEME is nil, use the value
of `mc-default-scheme'. Returns t on success, nil otherwise.

By default, this function is bound to `C-c e' in mail composing modes."
  (interactive
   (if current-prefix-arg
       (list nil
         (cdr (assoc (completing-read "Encryption Scheme: " mc-schemes)
             mc-schemes)))))

  (run-hooks 'mc-pre-encryption-hook)
  (let ((default-recipients
      (save-restriction
        (goto-char (point-min))
        (search-forward mail-header-separator)
        (narrow-to-region (point-min) (point))
        (concat (mail-fetch-field "to" nil t) ", "
            (mail-fetch-field "bcc" nil t) ", "
            (mail-fetch-field "cc" nil t)))))

    (or scheme (setq scheme mc-default-scheme))
    (setq recipients
      (cond (recipients        ; given as function argument
         (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients))
        (mc-use-default-recipients
         (mc-cleanup-recipient-headers default-recipients))
        (t            ; prompt for it
         (mc-cleanup-recipient-headers
          (read-from-minibuffer "Recipients: " default-recipients)))))

    (or recipients
    (error "No recipients!"))

    (goto-char (point-min))
    (search-forward (concat "\n" mail-header-separator "\n"))
    (if (mc-encrypt-region scheme recipients
                           (point) (point-max))
        (progn
          (run-hooks 'mc-post-encryption-hook)
          t)
      nil)))

(defsubst mc-encrypt-region (scheme recipients start end)
  ;; Encrypt region with SCHEME between START and END for
  ;; RECIPIENTS using BUFFER.
  (funcall (cdr (assoc 'encryption-func scheme)) recipients start end))

;;}}}
;;{{{ Decryption

;;;###autoload
(defun mc-decrypt-message ()
  "*Decrypt whatever message is in the current buffer.
Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption
succeeded and VERIFIED is t if it had a valid signature.

By default, this function is bound to `C-c d' in reading modes."
  (interactive)
  (let ((schemes mc-schemes)
    limits scheme)
    (while (and schemes
        (setq scheme (car schemes))
        (not (setq limits
               (mc-message-delimiter-positions
                (cdr (assoc 'msg-begin-line scheme))
                (cdr (assoc 'msg-end-line scheme))))))
      (setq schemes (cdr schemes)))

    (if (null limits)
        (error "Found no encrypted message in this buffer.")
      (run-hooks 'mc-pre-decryption-hook)
      (let ((resultval (funcall (cdr (assoc 'decryption-func scheme))
                                (car limits) (cdr limits))))
        (goto-char (point-min))
        (if (car resultval) ; decryption succeeded
            (run-hooks 'mc-post-decryption-hook))
        resultval))))
;;}}}
;;{{{ Signing

;;;###autoload
(defun mc-sign-message (&optional withkey scheme)
  "*Clear sign the message.
With one prefix arg, prompts for private key to use, with two prefix args,
also prompts for encryption scheme to use.

By default, this function is bound to `C-c s' in composition modes."
  (interactive
   (let (arglist)
     (if (not (and (listp current-prefix-arg)
           (numberp (car current-prefix-arg))))
     nil
       (if (>= (car current-prefix-arg) 16)
       (setq arglist (cons (cdr (assoc
                     (completing-read "Encryption Scheme: "
                              mc-schemes)
                     mc-schemes))
                   arglist)))
       (if (>= (car current-prefix-arg) 4)
       (setq arglist (cons (read-string "User ID: ") arglist))))
     arglist))
  (or scheme (setq scheme mc-default-scheme))
  (let (start)
    (goto-char (point-min))
    (search-forward (concat "\n" mail-header-separator "\n"))
    (funcall (cdr (assoc 'signing-func scheme))
         (point) (point-max) withkey)))

;;}}}
;;{{{ Signature verification

;;{{{ mc-verify-signature

;;;###autoload
(defun mc-verify-signature ()
  "*Verify the signature of the signed message in the current buffer.
Show the result as a message in the minibuffer. Returns t if the signature
is verified.

By default, this function is bound to `C-c v' in reading modes."
  (interactive)
  (let ((schemes mc-schemes)
    limits scheme)
    (while (and schemes
        (setq scheme (car schemes))
        (not (setq limits
               (mc-message-delimiter-positions
                (cdr (assoc 'signed-begin-line scheme))
                (cdr (assoc 'signed-end-line scheme))))))
      (setq schemes (cdr schemes)))

    (if (null limits)
    (error "Found no signed message in this buffer.")
      (funcall (cdr (assoc 'verification-func scheme))
           (car limits) (cdr limits)))))
;;}}}

;;}}}
;;{{{ Key management

;;{{{ mc-insert-public-key

;;;###autoload
(defun mc-insert-public-key (&optional userid scheme)
  "*Insert your public key at the end of the current buffer.
With one prefix arg, prompts for user id to use. With two prefix
args, prompts for encryption scheme."
  (interactive
   (let (arglist)
     (if (not (and (listp current-prefix-arg)
           (numberp (car current-prefix-arg))))
     nil
       (if (>= (car current-prefix-arg) 16)
       (setq arglist
         (cons (cdr (assoc (completing-read "Encryption Scheme: "
                            mc-schemes)
                   mc-schemes))
               arglist)))
       (if (>= (car current-prefix-arg) 4)
       (setq arglist (cons (read-string "User ID: ") arglist))))
     arglist))
  (or scheme (setq scheme mc-default-scheme))
  (or userid (setq userid (cdr (assoc 'user-id scheme))))

  (goto-char (point-max))
  (if (not (bolp))
      (insert "\n"))
  (funcall (cdr (assoc 'key-insertion-func scheme)) userid))
;;}}}
;;{{{ mc-snarf-keys

;;;###autoload
(defun mc-snarf-keys ()
  "*Add the first public key in the buffer to your keyring.
TODO: add ALL the keys in the buffer."
  (interactive)
  (let ((schemes mc-schemes)
    (start (point-min))
    limits scheme)
    (while (and schemes
        (setq scheme (car schemes))
        (not (setq limits
               (mc-message-delimiter-positions
                (cdr (assoc 'key-begin-line scheme))
                (cdr (assoc 'key-end-line scheme))
                start))))
      (setq schemes (cdr schemes)))
    (if (null limits)
    (error "Found no public key to snarf in this buffer.")
      (funcall (cdr (assoc 'snarf-func scheme))
           (car limits) (cdr limits)))))
;;}}}

;;}}}
;;{{{ Mode specific functions

(defvar mc-modes-alist
  (list (cons 'rmail-mode (list 'mc-rmail-decrypt-message
                'mc-rmail-verify-signature))
    (cons 'vm-mode (list 'mc-vm-decrypt-message
                 'mc-vm-verify-signature))
    (cons 'mh-folder-mode (list 'mc-mh-decrypt-message
                    'mc-mh-verify-signature
                    'mc-mh-snarf-keys))
    (cons 'gnus-summary-mode (list 'mc-gnus-summary-decrypt-message
                       'mc-gnus-summary-verify-signature
                       'mc-gnus-summary-snarf-keys)))
  "*Association list to specify mode specific functions for reading.
Entries are of the form (MODE . (DECRYPT VERIFY SNARF)).
The SNARF is optional and defaults to `mc-snarf-keys'.")

;;{{{ RMAIL
;;;###autoload
(defun mc-rmail-verify-signature ()
  "*Verify the signature in the current message."
  (interactive)
  (if (not (equal mode-name "RMAIL"))
      (error "mc-rmail-verify-signature called in a non-RMAIL buffer"))
  (if (mc-verify-signature)
      (rmail-add-label "verified")))

;;;###autoload
(defun mc-rmail-decrypt-message ()
  "*Decrypt the contents of this message"
  (interactive)
  (let ((oldbuf (current-buffer))
    noerr
    decryption-result)
    (if (not (equal mode-name "RMAIL"))
    (error "mc-rmail-decrypt-message called in a non-RMAIL buffer"))
    (rmail-edit-current-message)
    (cond ((not (progn
          (setq decryption-result (mc-decrypt-message))
          (car decryption-result)))
       (message "Decryption failed.")
       (rmail-abort-edit))
      ((or mc-always-replace
           (y-or-n-p "Replace encrypted message with decrypted? "))
       (rmail-cease-edit)
       (rmail-kill-label "edited")
       (rmail-add-label "decrypted")
       (if (cdr decryption-result)
           (rmail-add-label "verified")))
      (t
       (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*")))
         (copy-to-buffer tmp (point-min) (point-max))
         (rmail-abort-edit)
         (switch-to-buffer tmp t)
         (view-mode oldbuf 'kill-buffer))))))

;;}}}
;;{{{ VM
;;;###autoload
(defun mc-vm-verify-signature ()
  "*Verify the signature in the current VM message"
  (interactive)
  (if (interactive-p)
      (vm-follow-summary-cursor))
  (vm-select-folder-buffer)
  (vm-check-for-killed-summary)
  (vm-error-if-folder-empty)
  (mc-verify-signature))

;;;###autoload
(defun mc-vm-decrypt-message ()
  "*Decrypt the contents of the current VM message"
  (interactive)
  (let ((oldbuf (current-buffer))
    decryption-result)
    (if (interactive-p)
    (vm-follow-summary-cursor))
    (vm-select-folder-buffer)
    (vm-check-for-killed-summary)
    (vm-error-if-folder-read-only)
    (vm-error-if-folder-empty)
    (vm-edit-message)
    (cond ((not (prog1
                    (car (mc-decrypt-message))
                  (sit-for 1))) ; give it time to show the edit window
           (message "Decryption failed.")
           (vm-edit-message-abort))
          ((or mc-always-replace
               (y-or-n-p "Replace encrypted message with decrypted? "))
           (vm-edit-message-end))
          (t
           (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*")))
             (copy-to-buffer tmp (point-min) (point-max))
             (vm-edit-message-abort)
             (switch-to-buffer tmp t)
             (view-mode oldbuf 'kill-buffer))))))

;;}}}
;;{{{ GNUS

;;;###autoload
(defun mc-gnus-summary-verify-signature ()
  (interactive)
  (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers)
  (gnus-eval-in-buffer-window gnus-article-buffer
    (save-restriction (widen) (mc-verify-signature))))

;;;###autoload
(defun mc-gnus-summary-snarf-keys ()
  (interactive)
  (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers)
  (gnus-eval-in-buffer-window gnus-article-buffer
    (save-restriction (widen) (mc-snarf-keys))))

;;;###autoload
(defun mc-gnus-summary-decrypt-message ()
  (interactive)
  (gnus-summary-select-article gnus-save-all-headers gnus-save-all-headers)
  (gnus-eval-in-buffer-window gnus-article-buffer
    (save-restriction (widen) (mc-decrypt-message))))

;;}}}
;;{{{ MH

;;;###autoload
(defun mc-mh-decrypt-message (decrypt-on-disk)
  "*Decrypt the contents of the current MH message in the show buffer.
With prefix arg, decrypt the message on disk as well."
  (interactive "P")
  (let* ((msg (mh-get-msg-num t))
     (msg-filename (mh-msg-filename msg))
     (show-buffer (get-buffer mh-show-buffer))
     decrypt-okay)
    (setq decrypt-on-disk (or mc-always-replace decrypt-on-disk))
    (if decrypt-on-disk
    (progn
      (save-excursion
        (set-buffer (create-file-buffer msg-filename))
        (insert-file-contents msg-filename t)
        (if (setq decrypt-okay (car (mc-decrypt-message)))
        (save-buffer)
          (message "Decryption failed.")
          (set-buffer-modified-p nil))
        (kill-buffer nil))
      (if decrypt-okay
          (if (and show-buffer
               (equal msg-filename (buffer-file-name show-buffer)))
          (save-excursion
            (save-window-excursion
              (mh-invalidate-show-buffer)))))
      (mh-show msg))
      (mh-show msg)
      (save-excursion
    (set-buffer mh-show-buffer)
    (if (setq decrypt-okay (car (mc-decrypt-message)))
        (progn
          (goto-char (point-min))
          (set-buffer-modified-p nil))
      (message "Decryption failed.")))
      (if (not decrypt-okay)
      (progn
        (mh-invalidate-show-buffer)
        (mh-show msg))))))

;;;###autoload
(defun mc-mh-verify-signature ()
  "*Verify the signature in the current MH message."
  (interactive)
  (let ((msg (mh-get-msg-num t)))
    (mh-show msg)
    (save-excursion
      (set-buffer mh-show-buffer)
      (mc-verify-signature))))

;;;###autoload
(defun mc-mh-snarf-keys ()
  (interactive)
  (mh-show (mh-get-msg-num t))
  (save-excursion
    (set-buffer mh-show-buffer)
    (mc-snarf-keys)))


;;}}}

;;}}}
;;{{{ Menubar stuff

(defun mc-create-read-menu-bar ()
  ;; Create a menu bar entry for reading modes.
  (let ((decrypt (nth 0 (cdr (assoc major-mode mc-modes-alist))))
    (verify (nth 1 (cdr (assoc major-mode mc-modes-alist))))
    (snarf (nth 2 (cdr (assoc major-mode mc-modes-alist)))))
    (if (not (and decrypt verify))
    (error "Decrypt and verify functions not defined for this major mode."))
    (if (not snarf)
    (setq snarf 'mc-snarf-keys))
    (if (string-match "XEmacs" (emacs-version))
    (let ((x (list "Mailcrypt"
               (vector "Decrypt Message" decrypt t)
               (vector "Verify Signature" verify t)
               (vector "Snarf Public Key" snarf t))))
      (set-buffer-menubar current-menubar)
      (add-menu nil "Mailcrypt" (cdr x)))
      (local-set-key [menu-bar mailcrypt]
             (cons "Mailcrypt" (make-sparse-keymap "Mailcrypt")))
      (local-set-key [menu-bar mailcrypt decrypt]
             (cons "Decrypt Message" decrypt))
      (local-set-key [menu-bar mailcrypt verify]
             (cons "Verify Signature" verify))
      (local-set-key [menu-bar mailcrypt snarf]
             (cons "Snarf Public Key" snarf)))))

(defun mc-create-write-menu-bar ()
  ;; Create a menu bar entry for writing modes.
  (if (string-match "Lucid\\|XEmacs" (emacs-version))
      (let ((x (list "Mailcrypt"
             (vector "Encrypt Message" 'mc-encrypt-message t)
             (vector "Sign Message" 'mc-sign-message t)
             (vector "Insert Public Key" 'mc-insert-public-key t))))
    (set-buffer-menubar current-menubar)
    (add-menu nil "Mailcrypt" (cdr x)))
    (local-set-key [menu-bar mailcrypt]
           (cons "Mailcrypt" (make-sparse-keymap "Mailcrypt")))
    (local-set-key [menu-bar mailcrypt encrypt]
           (cons "Encrypt Message" 'mc-encrypt-message))
    (local-set-key [menu-bar mailcrypt sign]
           (cons "Sign Message" 'mc-sign-message))
    (local-set-key [menu-bar mailcrypt insert]
           (cons "Insert Public Key" 'mc-insert-public-key))))

;;}}}
;;{{{ Define several aliases so that an apropos on `mailcrypt' will
;; return something.
(fset 'mailcrypt-encrypt-message 'mc-encrypt-message)
(fset 'mailcrypt-decrypt-message 'mc-decrypt-message)
(fset 'mailcrypt-sign-message 'mc-sign-message)
(fset 'mailcrypt-verify-signature 'mc-verify-signature)
(fset 'mailcrypt-insert-public-keys 'mc-insert-public-key)
(fset 'mailcrypt-snarf-keys 'mc-snarf-keys)
;;}}}

(provide 'mailcrypt)