xemacs-beta: lisp/mailcrypt/mailcrypt.el comparison

comparison lisp/mailcrypt/mailcrypt.el @ 0:376386a54a3c r19-14

Import from CVS: tag r19-14

author	cvs
date	Mon, 13 Aug 2007 08:45:50 +0200
parents
children

comparison

equal deleted inserted replaced

--1:000000000000
+:376386a54a3c
+;; mailcrypt.el v3.4, mail encryption with PGP
+;; Copyright (C) 1995  Jin Choi <jin@atype.com>
+;;                     Patrick LoPresti <patl@lcs.mit.edu>
+;; Any comments or suggestions welcome.
+;; Inspired by pgp.el, by Gray Watson <gray@antaire.com>.
+;;{{{ 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.
+;;}}}
+;;{{{ Load some required packages
+(eval-when-compile
+;; Quiet warnings
+(autoload 'start-itimer "itimer")
+(autoload 'cancel-itimer "itimer")
+(autoload 'delete-itimer "itimer"))
+(require 'easymenu)
+(require 'comint)
+(eval-and-compile
+(condition-case nil (require 'itimer) (error nil))
+(if (not (featurep 'itimer))
+(condition-case nil (require 'timer) (error nil)))
+(if (not (fboundp 'buffer-substring-no-properties))
+(fset 'buffer-substring-no-properties 'buffer-substring)))
+(defconst mc-xemacs-p (string-match "XEmacs" emacs-version))
+(if (not mc-xemacs-p)
+(progn
+(autoload 'mc-decrypt "mc-toplev" nil t)
+(autoload 'mc-verify "mc-toplev" nil t)
+(autoload 'mc-snarf "mc-toplev" nil t)
+(autoload 'mc-pgp-fetch-key "mc-pgp" nil t)
+(autoload 'mc-encrypt "mc-toplev" nil t)
+(autoload 'mc-sign "mc-toplev" nil t)
+(autoload 'mc-insert-public-key "mc-toplev" nil t)
+(autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t)
+(autoload 'mc-remailer-insert-response-block "mc-remail" nil t)
+(autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t)))
+;;}}}
+;;{{{ Minor mode variables and functions
+(defvar mc-read-mode nil
+"Non-nil means Mailcrypt read mode key bindings are available.")
+(defvar mc-write-mode nil
+"Non-nil means Mailcrypt write mode key bindings are available.")
+(make-variable-buffer-local 'mc-read-mode)
+(make-variable-buffer-local 'mc-write-mode)
+(defvar mc-read-mode-string " MC-r"
+"*String to put in mode line when Mailcrypt read mode is active.")
+(defvar mc-write-mode-string " MC-w"
+"*String to put in mode line when Mailcrypt write mode is active.")
+(defvar mc-read-mode-map nil
+"Keymap for Mailcrypt read mode bindings.")
+(defvar mc-write-mode-map nil
+"Keymap for Mailcrypt write mode bindings.")
+(or mc-read-mode-map
+(progn
+(setq mc-read-mode-map (make-sparse-keymap))
+(define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd)
+(define-key mc-read-mode-map "\C-c/d" 'mc-decrypt)
+(define-key mc-read-mode-map "\C-c/v" 'mc-verify)
+(define-key mc-read-mode-map "\C-c/a" 'mc-snarf)
+(define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key)))
+(or mc-write-mode-map
+(progn
+(setq mc-write-mode-map (make-sparse-keymap))
+(define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd)
+(define-key mc-write-mode-map "\C-c/e" 'mc-encrypt)
+(define-key mc-write-mode-map "\C-c/s" 'mc-sign)
+(define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key)
+(define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key)
+(define-key mc-write-mode-map "\C-c/r"
+	'mc-remailer-encrypt-for-chain)
+(define-key mc-write-mode-map "\C-c/b"
+	'mc-remailer-insert-response-block)
+(define-key mc-write-mode-map "\C-c/p"
+	'mc-remailer-insert-pseudonym)))
+(easy-menu-define
+mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map))
+"Mailcrypt read mode menu."
+'("Mailcrypt"
+["Decrypt Message" mc-decrypt t]
+["Verify Signature" mc-verify t]
+["Snarf Keys" mc-snarf t]
+["Fetch Key" mc-pgp-fetch-key t]
+["Forget Passphrase(s)" mc-deactivate-passwd t]))
+(easy-menu-define
+mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map))
+"Mailcrypt write mode menu."
+'("Mailcrypt"
+["Encrypt Message" mc-encrypt t]
+["Sign Message" mc-sign t]
+["Insert Public Key" mc-insert-public-key t]
+["Fetch Key" mc-pgp-fetch-key t]
+["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t]
+["Insert Pseudonym" mc-remailer-insert-pseudonym t]
+["Insert Response Block" mc-remailer-insert-response-block t]
+["Forget Passphrase(s)" mc-deactivate-passwd t]))
+(or (assq 'mc-read-mode minor-mode-map-alist)
+(setq minor-mode-map-alist
+	  (cons (cons 'mc-read-mode mc-read-mode-map)
+		minor-mode-map-alist)))
+(or (assq 'mc-write-mode minor-mode-map-alist)
+(setq minor-mode-map-alist
+	  (cons (cons 'mc-write-mode mc-write-mode-map)
+		minor-mode-map-alist)))
+(or (assq 'mc-read-mode minor-mode-alist)
+(setq minor-mode-alist
+	  (cons '(mc-read-mode mc-read-mode-string) minor-mode-alist)))
+(or (assq 'mc-write-mode minor-mode-alist)
+(setq minor-mode-alist
+	  (cons '(mc-write-mode mc-write-mode-string) minor-mode-alist)))
+(defun mc-read-mode (&optional arg)
+"\nMinor mode for interfacing with cryptographic functions.
+\\<mc-read-mode-map>
+\\[mc-decrypt]\t\tDecrypt an encrypted message
+\\[mc-verify]\t\tVerify signature on a clearsigned message
+\\[mc-snarf]\t\tAdd public key(s) to keyring
+\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
+\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
+(interactive)
+(setq mc-read-mode
+	(if (null arg) (not mc-read-mode)
+	  (> (prefix-numeric-value arg) 0)))
+(and mc-read-mode mc-write-mode (mc-write-mode nil))
+(if mc-read-mode
+(easy-menu-add mc-read-mode-menu)
+(easy-menu-remove mc-read-mode-menu)))
+(defun mc-write-mode (&optional arg)
+"\nMinor mode for interfacing with cryptographic functions.
+\\<mc-write-mode-map>
+\\[mc-encrypt]\t\tEncrypt (and optionally sign) message
+\\[mc-sign]\t\tClearsign message
+\\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message
+\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
+\\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing
+\\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing)
+\\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing)
+\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
+(interactive)
+(setq mc-write-mode
+	(if (null arg) (not mc-write-mode)
+	  (> (prefix-numeric-value arg) 0)))
+(and mc-write-mode mc-read-mode (mc-read-mode nil))
+(if mc-write-mode
+(easy-menu-add mc-write-mode-menu)
+(easy-menu-remove mc-write-mode-menu)))
+;;;###autoload
+(defun mc-install-read-mode ()
+(interactive)
+(mc-read-mode 1))
+;;;###autoload
+(defun mc-install-write-mode ()
+(interactive)
+(mc-write-mode 1))
+;;}}}
+;;{{{ Note:
+;; The funny triple braces you see are used by `folding-mode', a minor
+;; mode by Jamie Lokier, available from the elisp archive.
+;;}}}
+;;{{{ User variables.
+(defconst mc-version "3.4")
+(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
+"*If t, decrypt mail messages in place without prompting.
+If 'never, always use a viewer instead of replacing.")
+(defvar mc-use-default-recipients nil "*Assume that the message should
+be encoded for everyone listed in the To, Cc, and Bcc fields.")
+(defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with
+user's public key.")
+(defvar mc-pre-signature-hook nil
+"*List of hook functions to run immediately before signing.")
+(defvar mc-post-signature-hook nil
+"*List of hook functions to run immediately after signing.")
+(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.")
+(defconst mc-buffer-name "*MailCrypt*"
+"Name of temporary buffer for mailcrypt")
+(defvar mc-modes-alist
+'((rmail-mode (decrypt . mc-rmail-decrypt-message)
+		(verify . mc-rmail-verify-signature))
+(rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message)
+			(verify . mc-rmail-summary-verify-signature)
+			(snarf . mc-rmail-summary-snarf-keys))
+(vm-mode (decrypt . mc-vm-decrypt-message)
+	     (verify . mc-vm-verify-signature)
+	     (snarf . mc-vm-snarf-keys))
+(vm-virtual-mode (decrypt . mc-vm-decrypt-message)
+		     (verify . mc-vm-verify-signature)
+		     (snarf . mc-vm-snarf-keys))
+(vm-summary-mode (decrypt . mc-vm-decrypt-message)
+		     (verify . mc-vm-verify-signature)
+		     (snarf . mc-vm-snarf-keys))
+(mh-folder-mode (decrypt . mc-mh-decrypt-message)
+		    (verify . mc-mh-verify-signature)
+		    (snarf . mc-mh-snarf-keys))
+;; September Gnus (5.2) has a new message editing mode
+(message-mode (encrypt . mc-encrypt-message)
+		  (sign . mc-sign-message))
+(gnus-summary-mode (decrypt . mc-gnus-decrypt-message)
+		       (verify . mc-gnus-verify-signature)
+		       (snarf . mc-gnus-snarf-keys))
+(gnus-article-mode (decrypt . mc-gnus-decrypt-message)
+		       (verify . mc-gnus-verify-signature)
+		       (snarf . mc-gnus-snarf-keys))
+(mail-mode (encrypt . mc-encrypt-message)
+	       (sign . mc-sign-message))
+(vm-mail-mode (encrypt . mc-encrypt-message)
+		  (sign . mc-sign-message))
+(mh-letter-mode (encrypt . mc-encrypt-message)
+		    (sign . mc-sign-message))
+(news-reply-mode (encrypt . mc-encrypt-message)
+		     (sign . mc-sign-message)))
+"Association list (indexed by major mode) of association lists
+(indexed by operation) of functions to call for each major mode.")
+;;}}}
+;;{{{ Program variables and constants.
+(defvar mc-timer nil "Timer object for password deactivation.")
+(defvar mc-passwd-cache nil "Cache for passphrases.")
+(defvar mc-schemes '(("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.
+(setq begin (or begin (point-min)))
+(let (start)
+(save-excursion
+(goto-char begin)
+(and (re-search-forward start-re nil t)
+	   (setq start (match-beginning 0))
+	   (re-search-forward end-re nil t)
+	   (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))
+	  (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))))
+;;; FIXME - Function never called?
+;(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))))))
+;; In case I ever decide to do this right.
+(defconst mc-field-name-regexp "^\\(.+\\)")
+(defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)")
+(defun mc-get-fields (&optional matching bounds nuke)
+"Get all header fields within BOUNDS.  Return as an
+alist ((FIELD-NAME . FIELD-BODY) (FIELD-NAME . FIELD-BODY) ...).
+Argument MATCHING, if present, is a regexp which each FIELD-NAME
+must match exactly.  Matching is case-insensitive.
+Optional arg NUKE, if non-nil, means eliminate all fields returned."
+(save-excursion
+(save-restriction
+(let ((case-fold-search t)
+	    (header-field-regexp
+	     (concat mc-field-name-regexp ":" mc-field-body-regexp))
+	    ret name body field-start field-end)
+	;; Ensure exact match
+	(if matching
+	    (setq matching (concat "^\\(" matching "\\)$")))
+	(if bounds
+	    (narrow-to-region (car bounds) (cdr bounds)))
+	(goto-char (point-max))
+	(while (re-search-backward header-field-regexp nil 'move)
+	  (setq field-start (match-beginning 0))
+	  (setq field-end (match-end 0))
+	  (setq name (buffer-substring-no-properties
+		      (match-beginning 1) (match-end 1)))
+	  (setq body (buffer-substring-no-properties
+		      (match-beginning 2) (match-end 2)))
+	  (if (or (null matching) (string-match matching name))
+	      (progn
+		(setq ret (cons (cons name body) ret))
+		(if nuke
+		    (delete-region field-start field-end)))))
+	ret))))
+(defsubst mc-strip-address (addr)
+"Strip everything from ADDR except the basic Email address."
+(car (cdr (mail-extract-address-components addr))))
+(defun mc-strip-addresses (addr-list)
+"Strip everything from the addresses in ADDR-LIST except the basic
+Email address.  ADDR-LIST may be a single string or a list of strings."
+(if (not (listp addr-list)) (setq addr-list (list addr-list)))
+(setq addr-list
+	(mapcar
+	 (function (lambda (s) (mc-split "\\([ \t\n]*,[ \t\n]*\\)" s)))
+	 addr-list))
+(setq addr-list (apply 'append addr-list))
+(mapconcat 'mc-strip-address addr-list ", "))
+(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)
+;; 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-no-properties
+		     (match-beginning 0) (match-end 0))
+		  (setq retval nil)
+		  default))))
+(if msg (message "%s" msg))
+retval))
+(defun mc-process-region (beg end passwd program args parser &optional buffer)
+(let ((obuf (current-buffer))
+	(process-connection-type nil)
+	mybuf result rgn proc)
+(unwind-protect
+	(progn
+	  (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
+	  (set-buffer mybuf)
+	  (erase-buffer)
+	  (set-buffer obuf)
+	  (buffer-disable-undo mybuf)
+	  (setq proc
+		(apply 'start-process "*PGP*" mybuf program args))
+	  (if passwd
+	      (progn
+		(process-send-string proc (concat passwd "\n"))
+		(or mc-passwd-timeout (mc-deactivate-passwd t))))
+	  (process-send-region proc beg end)
+	  (process-send-eof proc)
+	  (while (eq 'run (process-status proc))
+	    (accept-process-output proc 5))
+	  (setq result (process-exit-status proc))
+	  ;; Hack to force a status_notify() in Emacs 19.29
+	  (delete-process proc)
+	  (set-buffer mybuf)
+	  (goto-char (point-max))
+	  (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
+	      (delete-region (match-beginning 0) (match-end 0)))
+	  (goto-char (point-min))
+	  ;; CRNL -> NL
+	  (while (search-forward "\r\n" nil t)
+	    (replace-match "\n"))
+	  ;; Hurm.  FIXME; must get better result codes.
+	  (if (stringp result)
+	      (error "%s exited abnormally: '%s'" program result)
+	    (setq rgn (funcall parser result))
+	    ;; If the parser found something, migrate it
+	    (if (consp rgn)
+		(progn
+		  (set-buffer obuf)
+		  (delete-region beg end)
+		  (goto-char beg)
+		  (insert-buffer-substring mybuf (car rgn) (cdr rgn))
+		  (set-buffer mybuf)
+		  (delete-region (car rgn) (cdr rgn)))))
+	  ;; Return nil on failure and exit code on success
+	  (if rgn result))
+;; Cleanup even on nonlocal exit
+(if (and proc (eq 'run (process-status proc)))
+	  (interrupt-process proc))
+(set-buffer obuf)
+(or buffer (null mybuf) (kill-buffer mybuf)))))
+;;}}}
+;;{{{ Passphrase management
+(defun mc-activate-passwd (id &optional prompt)
+"Activate the passphrase matching ID, using PROMPT for a prompt.
+Return the passphrase.  If PROMPT is nil, only return value if cached."
+(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)
+			  nil)))
+	((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)))))
+(let ((cell (assoc id mc-passwd-cache))
+	passwd)
+(setq passwd (cdr-safe cell))
+(if (and (not passwd) prompt)
+	(setq passwd (comint-read-noecho prompt)))
+(if cell
+	(setcdr cell passwd)
+(setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache)))
+passwd))
+;;;###autoload
+(defun mc-deactivate-passwd (&optional inhibit-message)
+"*Deactivate the passphrase cache."
+(interactive)
+(if mc-timer
+(cond ((featurep 'itimer) (delete-itimer mc-timer))
+	    ((featurep 'timer) (cancel-timer mc-timer))))
+(mapcar
+(function
+(lambda (cell)
+(if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0))
+(setcdr cell nil)))
+mc-passwd-cache)
+(or inhibit-message
+(not (interactive-p))
+(message "Passphrase%s deactivated"
+	       (if (> (length mc-passwd-cache) 1) "s" ""))))
+;;}}}
+;;{{{ Define several aliases so that an apropos on `mailcrypt' will
+;; return something.
+(defalias 'mailcrypt-encrypt 'mc-encrypt)
+(defalias 'mailcrypt-decrypt 'mc-decrypt)
+(defalias 'mailcrypt-sign 'mc-sign)
+(defalias 'mailcrypt-verify 'mc-verify)
+(defalias 'mailcrypt-insert-public-key 'mc-insert-public-key)
+(defalias 'mailcrypt-snarf 'mc-snarf)
+;;}}}
+(provide 'mailcrypt)

Mercurial > hg > xemacs-beta

comparison lisp/mailcrypt/mailcrypt.el @ 0:376386a54a3c r19-14