[bpt/emacs.git] / lisp / pgg-pgp.el

;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.

;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
;;   2005, 2006 Free Software Foundation, Inc.

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/11/02
;; Keywords: PGP, OpenPGP

;; This file is part of GNU Emacs.

;; GNU Emacs 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.

;; GNU Emacs 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, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(eval-when-compile
  (require 'cl)				; for pgg macros
  (require 'pgg))

(defgroup pgg-pgp ()
  "PGP 2.* and 6.* interface."
  :group 'pgg)

(defcustom pgg-pgp-program "pgp"
  "PGP 2.* and 6.* executable."
  :group 'pgg-pgp
  :type 'string)

(defcustom pgg-pgp-shell-file-name "/bin/sh"
  "File name to load inferior shells from.
Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
  :group 'pgg-pgp
  :type 'string)

(defcustom pgg-pgp-shell-command-switch "-c"
  "Switch used to have the shell execute its command line argument."
  :group 'pgg-pgp
  :type 'string)

(defcustom pgg-pgp-extra-args nil
  "Extra arguments for every PGP invocation."
  :group 'pgg-pgp
  :type '(choice
	  (const :tag "None" nil)
	  (string :tag "Arguments")))

(defvar pgg-pgp-user-id nil
  "PGP ID of your default identity.")

(defun pgg-pgp-process-region (start end passphrase program args)
  (let* ((errors-file-name (pgg-make-temp-file "pgg-errors"))
	 (args
	  (append args
		  pgg-pgp-extra-args
		  (list (concat "2>" errors-file-name))))
	 (shell-file-name pgg-pgp-shell-file-name)
	 (shell-command-switch pgg-pgp-shell-command-switch)
	 (process-environment process-environment)
	 (output-buffer pgg-output-buffer)
	 (errors-buffer pgg-errors-buffer)
	 (process-connection-type nil)
	 process status exit-status)
    (with-current-buffer (get-buffer-create output-buffer)
      (buffer-disable-undo)
      (erase-buffer))
    (when passphrase
      (setenv "PGPPASSFD" "0"))
    (unwind-protect
	(progn
	  (let ((coding-system-for-read 'binary)
		(coding-system-for-write 'binary))
	    (setq process
		  (apply #'funcall
			 #'start-process-shell-command "*PGP*" output-buffer
			 program args)))
	  (set-process-sentinel process #'ignore)
	  (when passphrase
	    (process-send-string process (concat passphrase "\n")))
	  (process-send-region process start end)
	  (process-send-eof process)
	  (while (eq 'run (process-status process))
	    (accept-process-output process 5))
	  (setq status (process-status process)
		exit-status (process-exit-status process))
	  (delete-process process)
	  (with-current-buffer output-buffer
	    (pgg-convert-lbt-region (point-min)(point-max) 'LF)

	    (if (memq status '(stop signal))
		(error "%s exited abnormally: '%s'" program exit-status))
	    (if (= 127 exit-status)
		(error "%s could not be found" program))

	    (set-buffer (get-buffer-create errors-buffer))
	    (buffer-disable-undo)
	    (erase-buffer)
	    (insert-file-contents errors-file-name)))
      (if (and process (eq 'run (process-status process)))
	  (interrupt-process process))
      (condition-case nil
	  (delete-file errors-file-name)
	(file-error nil)))))

(defun pgg-pgp-lookup-key (string &optional type)
  "Search keys associated with STRING."
  (let ((args (list "+batchmode" "+language=en" "-kv" string)))
    (with-current-buffer (get-buffer-create pgg-output-buffer)
      (buffer-disable-undo)
      (erase-buffer)
      (apply #'call-process pgg-pgp-program nil t nil args)
      (goto-char (point-min))
      (cond
       ((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.*
	(buffer-substring (point)(+ 8 (point))))
       ((re-search-forward "^Type" nil t);PGP 6.*
	(beginning-of-line 2)
	(substring
	 (nth 2 (split-string
		 (buffer-substring (point)(progn (end-of-line) (point)))))
	 2))))))

(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase)
  "Encrypt the current region between START and END."
  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	 (passphrase (or passphrase
                         (when sign
                           (pgg-read-passphrase
                            (format "PGP passphrase for %s: "
                                    pgg-pgp-user-id)
                            pgg-pgp-user-id))))
	 (args
          (append
           `("+encrypttoself=off +verbose=1" "+batchmode"
             "+language=us" "-fate"
             ,@(if recipients
                   (mapcar (lambda (rcpt) (concat "\"" rcpt "\""))
                           (append recipients
                                   (if pgg-encrypt-for-me
                                       (list pgg-pgp-user-id))))))
           (if sign '("-s" "-u" pgg-pgp-user-id)))))
    (pgg-pgp-process-region start end nil pgg-pgp-program args)
    (pgg-process-when-success nil)))

(defun pgg-pgp-decrypt-region (start end &optional passphrase)
  "Decrypt the current region between START and END.

If optional PASSPHRASE is not specified, it will be obtained from the
passphrase cache or user."
  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	 (key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt))
	 (passphrase
          (or passphrase
              (pgg-read-passphrase
               (format "PGP passphrase for %s: " pgg-pgp-user-id) key)))
	 (args
          '("+verbose=1" "+batchmode" "+language=us" "-f")))
    (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
    (pgg-process-when-success
      (if pgg-cache-passphrase
	  (pgg-add-passphrase-to-cache key passphrase)))))

(defun pgg-pgp-sign-region (start end &optional clearsign passphrase)
  "Make detached signature from text between START and END.

If optional PASSPHRASE is not specified, it will be obtained from the
passphrase cache or user."
  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	 (passphrase
          (or passphrase
              (pgg-read-passphrase
               (format "PGP passphrase for %s: " pgg-pgp-user-id)
               (pgg-pgp-lookup-key pgg-pgp-user-id 'sign))))
	 (args
	  (list (if clearsign "-fast" "-fbast")
		"+verbose=1" "+language=us" "+batchmode"
		"-u" pgg-pgp-user-id)))
    (pgg-pgp-process-region start end passphrase pgg-pgp-program args)
    (pgg-process-when-success
      (goto-char (point-min))
      (when (re-search-forward "^-+BEGIN PGP" nil t);XXX
	(let ((packet
	       (cdr (assq 2 (pgg-parse-armor-region
			     (progn (beginning-of-line 2)
				    (point))
			     (point-max))))))
	  (if pgg-cache-passphrase
	      (pgg-add-passphrase-to-cache
	       (cdr (assq 'key-identifier packet))
	       passphrase)))))))

(defun pgg-pgp-verify-region (start end &optional signature)
  "Verify region between START and END as the detached signature SIGNATURE."
  (let* ((orig-file (pgg-make-temp-file "pgg"))
	 (args '("+verbose=1" "+batchmode" "+language=us"))
	 (orig-mode (default-file-modes)))
    (unwind-protect
	(progn
	  (set-default-file-modes 448)
	  (let ((coding-system-for-write 'binary)
		jka-compr-compression-info-list jam-zcat-filename-list)
	    (write-region start end orig-file)))
      (set-default-file-modes orig-mode))
    (if (stringp signature)
	(progn
	  (copy-file signature (setq signature (concat orig-file ".asc")))
	  (setq args (append args (list signature orig-file))))
      (setq args (append args (list orig-file))))
    (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
    (delete-file orig-file)
    (if signature (delete-file signature))
    (pgg-process-when-success
      (goto-char (point-min))
      (let ((case-fold-search t))
	(while (re-search-forward "^warning: " nil t)
	  (delete-region (match-beginning 0)
			 (progn (beginning-of-line 2) (point)))))
      (goto-char (point-min))
      (when (re-search-forward "^\\.$" nil t)
	(delete-region (point-min)
		       (progn (beginning-of-line 2)
			      (point)))))))

(defun pgg-pgp-insert-key ()
  "Insert public key at point."
  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	 (args
	  (list "+verbose=1" "+batchmode" "+language=us" "-kxaf"
		(concat "\"" pgg-pgp-user-id "\""))))
    (pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
    (insert-buffer-substring pgg-output-buffer)))

(defun pgg-pgp-snarf-keys-region (start end)
  "Add all public keys in region between START and END to the keyring."
  (let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	 (key-file (pgg-make-temp-file "pgg"))
	 (args
	  (list "+verbose=1" "+batchmode" "+language=us" "-kaf"
		key-file)))
    (let ((coding-system-for-write 'raw-text-dos))
      (write-region start end key-file))
    (pgg-pgp-process-region start end nil pgg-pgp-program args)
    (delete-file key-file)
    (pgg-process-when-success nil)))

(provide 'pgg-pgp)

;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c
;;; pgg-pgp.el ends here
Commit	Line	Data
23f87bed MB	1	;;; pgg-pgp.el --- PGP 2.* and 6.* support for PGG.
23f87bed MB	2
e84b4b86	3	;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
aaef169d	4	;; 2005, 2006 Free Software Foundation, Inc.
23f87bed MB	5
	6	;; Author: Daiki Ueno <ueno@unixuser.org>
	7	;; Created: 1999/11/02
	8	;; Keywords: PGP, OpenPGP
	9
	10	;; This file is part of GNU Emacs.
	11
	12	;; GNU Emacs is free software; you can redistribute it and/or modify
	13	;; it under the terms of the GNU General Public License as published by
	14	;; the Free Software Foundation; either version 2, or (at your option)
	15	;; any later version.
	16
	17	;; GNU Emacs is distributed in the hope that it will be useful,
	18	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;; GNU General Public License for more details.
	21
	22	;; You should have received a copy of the GNU General Public License
	23	;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56 LK	24	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
3a35cf56 LK	25	;; Boston, MA 02110-1301, USA.
23f87bed MB	26
	27	;;; Code:
	28
	29	(eval-when-compile
	30	(require 'cl) ; for pgg macros
	31	(require 'pgg))
	32
	33	(defgroup pgg-pgp ()
5a210b89	34	"PGP 2.* and 6.* interface."
23f87bed MB	35	:group 'pgg)
	36
	37	(defcustom pgg-pgp-program "pgp"
	38	"PGP 2.* and 6.* executable."
	39	:group 'pgg-pgp
	40	:type 'string)
	41
	42	(defcustom pgg-pgp-shell-file-name "/bin/sh"
	43	"File name to load inferior shells from.
	44	Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"."
	45	:group 'pgg-pgp
	46	:type 'string)
	47
	48	(defcustom pgg-pgp-shell-command-switch "-c"
	49	"Switch used to have the shell execute its command line argument."
	50	:group 'pgg-pgp
	51	:type 'string)
	52
	53	(defcustom pgg-pgp-extra-args nil
	54	"Extra arguments for every PGP invocation."
	55	:group 'pgg-pgp
	56	:type '(choice
	57	(const :tag "None" nil)
	58	(string :tag "Arguments")))
	59
	60	(defvar pgg-pgp-user-id nil
	61	"PGP ID of your default identity.")
	62
	63	(defun pgg-pgp-process-region (start end passphrase program args)
	64	(let* ((errors-file-name (pgg-make-temp-file "pgg-errors"))
	65	(args
	66	(append args
	67	pgg-pgp-extra-args
	68	(list (concat "2>" errors-file-name))))
	69	(shell-file-name pgg-pgp-shell-file-name)
	70	(shell-command-switch pgg-pgp-shell-command-switch)
	71	(process-environment process-environment)
	72	(output-buffer pgg-output-buffer)
	73	(errors-buffer pgg-errors-buffer)
	74	(process-connection-type nil)
	75	process status exit-status)
	76	(with-current-buffer (get-buffer-create output-buffer)
	77	(buffer-disable-undo)
	78	(erase-buffer))
	79	(when passphrase
	80	(setenv "PGPPASSFD" "0"))
	81	(unwind-protect
	82	(progn
	83	(let ((coding-system-for-read 'binary)
	84	(coding-system-for-write 'binary))
	85	(setq process
	86	(apply #'funcall
	87	#'start-process-shell-command "PGP" output-buffer
	88	program args)))
	89	(set-process-sentinel process #'ignore)
	90	(when passphrase
	91	(process-send-string process (concat passphrase "\n")))
	92	(process-send-region process start end)
	93	(process-send-eof process)
	94	(while (eq 'run (process-status process))
	95	(accept-process-output process 5))
	96	(setq status (process-status process)
	97	exit-status (process-exit-status process))
	98	(delete-process process)
99	(with-current-buffer output-buffer
100	(pgg-convert-lbt-region (point-min)(point-max) 'LF)
101
102	(if (memq status '(stop signal))
103	(error "%s exited abnormally: '%s'" program exit-status))
104	(if (= 127 exit-status)
105	(error "%s could not be found" program))
106
107	(set-buffer (get-buffer-create errors-buffer))
108	(buffer-disable-undo)
109	(erase-buffer)
110	(insert-file-contents errors-file-name)))
111	(if (and process (eq 'run (process-status process)))
112	(interrupt-process process))
113	(condition-case nil
114	(delete-file errors-file-name)
115	(file-error nil)))))
116
117	(defun pgg-pgp-lookup-key (string &optional type)
118	"Search keys associated with STRING."
119	(let ((args (list "+batchmode" "+language=en" "-kv" string)))
120	(with-current-buffer (get-buffer-create pgg-output-buffer)
121	(buffer-disable-undo)
122	(erase-buffer)
123	(apply #'call-process pgg-pgp-program nil t nil args)
124	(goto-char (point-min))
125	(cond
126	((re-search-forward "^pub\\s +[0-9]+/" nil t);PGP 2.*
127	(buffer-substring (point)(+ 8 (point))))
128	((re-search-forward "^Type" nil t);PGP 6.*
129	(beginning-of-line 2)
130	(substring
131	(nth 2 (split-string
132	(buffer-substring (point)(progn (end-of-line) (point)))))
133	2))))))
134
c6037c00	135	(defun pgg-pgp-encrypt-region (start end recipients &optional sign passphrase)
23f87bed MB	136	"Encrypt the current region between START and END."
23f87bed MB	137	(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
c6037c00 EZ	138	(passphrase (or passphrase
	139	(when sign
	140	(pgg-read-passphrase
	141	(format "PGP passphrase for %s: "
	142	pgg-pgp-user-id)
	143	pgg-pgp-user-id))))
23f87bed	144	(args
c6037c00 EZ	145	(append
	146	`("+encrypttoself=off +verbose=1" "+batchmode"
	147	"+language=us" "-fate"
	148	,@(if recipients
	149	(mapcar (lambda (rcpt) (concat "\"" rcpt "\""))
	150	(append recipients
	151	(if pgg-encrypt-for-me
	152	(list pgg-pgp-user-id))))))
	153	(if sign '("-s" "-u" pgg-pgp-user-id)))))
23f87bed MB	154	(pgg-pgp-process-region start end nil pgg-pgp-program args)
	155	(pgg-process-when-success nil)))
	156
c6037c00 EZ	157	(defun pgg-pgp-decrypt-region (start end &optional passphrase)
	158	"Decrypt the current region between START and END.
	159
	160	If optional PASSPHRASE is not specified, it will be obtained from the
	161	passphrase cache or user."
23f87bed	162	(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
710f2e1b	163	(key (pgg-pgp-lookup-key pgg-pgp-user-id 'encrypt))
23f87bed	164	(passphrase
c6037c00 EZ	165	(or passphrase
	166	(pgg-read-passphrase
	167	(format "PGP passphrase for %s: " pgg-pgp-user-id) key)))
23f87bed	168	(args
c6037c00	169	'("+verbose=1" "+batchmode" "+language=us" "-f")))
23f87bed	170	(pgg-pgp-process-region start end passphrase pgg-pgp-program args)
710f2e1b SJ	171	(pgg-process-when-success
710f2e1b SJ	172	(if pgg-cache-passphrase
c6037c00 EZ	173	(pgg-add-passphrase-to-cache key passphrase)))))
	174
	175	(defun pgg-pgp-sign-region (start end &optional clearsign passphrase)
	176	"Make detached signature from text between START and END.
23f87bed	177
c6037c00 EZ	178	If optional PASSPHRASE is not specified, it will be obtained from the
c6037c00 EZ	179	passphrase cache or user."
23f87bed MB	180	(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
23f87bed MB	181	(passphrase
c6037c00 EZ	182	(or passphrase
	183	(pgg-read-passphrase
	184	(format "PGP passphrase for %s: " pgg-pgp-user-id)
	185	(pgg-pgp-lookup-key pgg-pgp-user-id 'sign))))
23f87bed MB	186	(args
	187	(list (if clearsign "-fast" "-fbast")
	188	"+verbose=1" "+language=us" "+batchmode"
	189	"-u" pgg-pgp-user-id)))
	190	(pgg-pgp-process-region start end passphrase pgg-pgp-program args)
	191	(pgg-process-when-success
	192	(goto-char (point-min))
	193	(when (re-search-forward "^-+BEGIN PGP" nil t);XXX
	194	(let ((packet
	195	(cdr (assq 2 (pgg-parse-armor-region
	196	(progn (beginning-of-line 2)
	197	(point))
	198	(point-max))))))
	199	(if pgg-cache-passphrase
c6037c00	200	(pgg-add-passphrase-to-cache
23f87bed MB	201	(cdr (assq 'key-identifier packet))
	202	passphrase)))))))
	203
	204	(defun pgg-pgp-verify-region (start end &optional signature)
	205	"Verify region between START and END as the detached signature SIGNATURE."
	206	(let* ((orig-file (pgg-make-temp-file "pgg"))
	207	(args '("+verbose=1" "+batchmode" "+language=us"))
	208	(orig-mode (default-file-modes)))
	209	(unwind-protect
	210	(progn
	211	(set-default-file-modes 448)
	212	(let ((coding-system-for-write 'binary)
	213	jka-compr-compression-info-list jam-zcat-filename-list)
	214	(write-region start end orig-file)))
	215	(set-default-file-modes orig-mode))
	216	(if (stringp signature)
	217	(progn
	218	(copy-file signature (setq signature (concat orig-file ".asc")))
	219	(setq args (append args (list signature orig-file))))
	220	(setq args (append args (list orig-file))))
	221	(pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
	222	(delete-file orig-file)
	223	(if signature (delete-file signature))
	224	(pgg-process-when-success
	225	(goto-char (point-min))
	226	(let ((case-fold-search t))
	227	(while (re-search-forward "^warning: " nil t)
	228	(delete-region (match-beginning 0)
	229	(progn (beginning-of-line 2) (point)))))
	230	(goto-char (point-min))
	231	(when (re-search-forward "^\\.$" nil t)
	232	(delete-region (point-min)
	233	(progn (beginning-of-line 2)
	234	(point)))))))
	235
	236	(defun pgg-pgp-insert-key ()
	237	"Insert public key at point."
	238	(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	239	(args
	240	(list "+verbose=1" "+batchmode" "+language=us" "-kxaf"
	241	(concat "\"" pgg-pgp-user-id "\""))))
	242	(pgg-pgp-process-region (point)(point) nil pgg-pgp-program args)
	243	(insert-buffer-substring pgg-output-buffer)))
	244
	245	(defun pgg-pgp-snarf-keys-region (start end)
	246	"Add all public keys in region between START and END to the keyring."
	247	(let* ((pgg-pgp-user-id (or pgg-pgp-user-id pgg-default-user-id))
	248	(key-file (pgg-make-temp-file "pgg"))
	249	(args
	250	(list "+verbose=1" "+batchmode" "+language=us" "-kaf"
	251	key-file)))
	252	(let ((coding-system-for-write 'raw-text-dos))
	253	(write-region start end key-file))
	254	(pgg-pgp-process-region start end nil pgg-pgp-program args)
	255	(delete-file key-file)
	256	(pgg-process-when-success nil)))
	257
	258	(provide 'pgg-pgp)
	259
	260	;;; arch-tag: 076b7801-37b2-49a6-97c3-218fdecde33c
	261	;;; pgg-pgp.el ends here