[bpt/emacs.git] / lisp / gnus / pgg.el

;;; pgg.el --- glue for the various PGP implementations.

;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1999/10/28
;; Keywords: PGP

;; 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., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(require 'pgg-def)
(require 'pgg-parse)
(autoload 'run-at-time "timer")

;; Don't merge these two `eval-when-compile's.
(eval-when-compile
  (require 'cl))
;; Fixme: This would be better done with an autoload for
;; `url-insert-file-contents', and the url stuff rationalized.
;; (`locate-library' can say whether the url code is available.)
(eval-when-compile
  (ignore-errors
    (require 'w3)
    (require 'url)))

;;; @ utility functions
;;;

(defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents)
				   (function pgg-fetch-key-with-w3)))

(defun pgg-invoke (func scheme &rest args)
  (progn
    (require (intern (format "pgg-%s" scheme)))
    (apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))

(put 'pgg-save-coding-system 'lisp-indent-function 2)

(defmacro pgg-save-coding-system (start end &rest body)
  `(if (interactive-p)
       (let ((buffer (current-buffer)))
	 (with-temp-buffer
	   (let (buffer-undo-list)
	     (insert-buffer-substring buffer ,start ,end)
	     (encode-coding-region (point-min)(point-max)
				   buffer-file-coding-system)
	     (prog1 (save-excursion ,@body)
	       (push nil buffer-undo-list)
	       (ignore-errors (undo))))))
     (save-restriction
       (narrow-to-region ,start ,end)
       ,@body)))

(defun pgg-temp-buffer-show-function (buffer)
  (let ((window (or (get-buffer-window buffer 'visible)
		    (split-window-vertically))))
    (set-window-buffer window buffer)
    (shrink-window-if-larger-than-buffer window)))

(defun pgg-display-output-buffer (start end status)
  (if status
      (progn
	(delete-region start end)
	(insert-buffer-substring pgg-output-buffer)
	(decode-coding-region start (point) buffer-file-coding-system))
    (let ((temp-buffer-show-function
	   (function pgg-temp-buffer-show-function)))
      (with-output-to-temp-buffer pgg-echo-buffer
	(set-buffer standard-output)
	(insert-buffer-substring pgg-errors-buffer)))))

(defvar pgg-passphrase-cache (make-vector 7 0))

(defun pgg-read-passphrase (prompt &optional key)
  (or (and pgg-cache-passphrase
	   key (setq key (pgg-truncate-key-identifier key))
	   (symbol-value (intern-soft key pgg-passphrase-cache)))
      (read-passwd prompt)))

(eval-when-compile
  (defvar itimer-process)
  (defvar itimer-timer)
  (autoload 'delete-itimer "itimer")
  (autoload 'itimer-driver-start "itimer")
  (autoload 'itimer-value "itimer")
  (autoload 'set-itimer-function "itimer")
  (autoload 'set-itimer-function-arguments "itimer")
  (autoload 'set-itimer-restart "itimer")
  (autoload 'start-itimer "itimer"))

(eval-and-compile
  (defalias
    'pgg-run-at-time
    (if (featurep 'xemacs)
	(if (condition-case nil
		(progn
		  (unless (or itimer-process itimer-timer)
		    (itimer-driver-start))
		  ;; Check whether there is a bug to which the difference of
		  ;; the present time and the time when the itimer driver was
		  ;; woken up is subtracted from the initial itimer value.
		  (let* ((inhibit-quit t)
			 (ctime (current-time))
			 (itimer-timer-last-wakeup
			  (prog1
			      ctime
			    (setcar ctime (1- (car ctime)))))
			 (itimer-list nil)
			 (itimer (start-itimer "pgg-run-at-time" 'ignore 5)))
		    (sleep-for 0.1) ;; Accept the timeout interrupt.
		    (prog1
			(> (itimer-value itimer) 0)
		      (delete-itimer itimer))))
	      (error nil))
	    (lambda (time repeat function &rest args)
	      "Emulating function run as `run-at-time'.
TIME should be nil meaning now, or a number of seconds from now.
Return an itimer object which can be used in either `delete-itimer'
or `cancel-timer'."
	      (apply #'start-itimer "pgg-run-at-time"
		     function (if time (max time 1e-9) 1e-9)
		     repeat nil t args))
	  (lambda (time repeat function &rest args)
	    "Emulating function run as `run-at-time' in the right way.
TIME should be nil meaning now, or a number of seconds from now.
Return an itimer object which can be used in either `delete-itimer'
or `cancel-timer'."
	    (let ((itimers (list nil)))
	      (setcar
	       itimers
	       (apply #'start-itimer "pgg-run-at-time"
		      (lambda (itimers repeat function &rest args)
			(let ((itimer (car itimers)))
			  (if repeat
			      (progn
				(set-itimer-function
				 itimer
				 (lambda (itimer repeat function &rest args)
				   (set-itimer-restart itimer repeat)
				   (set-itimer-function itimer function)
				   (set-itimer-function-arguments itimer args)
				   (apply function args)))
				(set-itimer-function-arguments
				 itimer
				 (append (list itimer repeat function) args)))
			    (set-itimer-function
			     itimer
			     (lambda (itimer function &rest args)
			       (delete-itimer itimer)
			       (apply function args)))
			    (set-itimer-function-arguments
			     itimer
			     (append (list itimer function) args)))))
		      1e-9 (if time (max time 1e-9) 1e-9)
		      nil t itimers repeat function args)))))
      'run-at-time)))

(defun pgg-add-passphrase-cache (key passphrase)
  (setq key (pgg-truncate-key-identifier key))
  (set (intern key pgg-passphrase-cache)
       passphrase)
  (pgg-run-at-time pgg-passphrase-cache-expiry nil
		   #'pgg-remove-passphrase-cache
		   key))

(defun pgg-remove-passphrase-cache (key)
  (let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
    (when passphrase
      (fillarray passphrase ?_)
      (unintern key pgg-passphrase-cache))))

(defmacro pgg-convert-lbt-region (start end lbt)
  `(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
     (goto-char ,start)
     (case ,lbt
       (CRLF
	(while (progn
		 (end-of-line)
		 (> (marker-position pgg-conversion-end) (point)))
	  (insert "\r")
	  (forward-line 1)))
       (LF
	(while (re-search-forward "\r$" pgg-conversion-end t)
	  (replace-match ""))))))

(put 'pgg-as-lbt 'lisp-indent-function 3)

(defmacro pgg-as-lbt (start end lbt &rest body)
  `(let ((inhibit-read-only t)
	 buffer-read-only
	 buffer-undo-list)
     (pgg-convert-lbt-region ,start ,end ,lbt)
     (let ((,end (point)))
       ,@body)
     (push nil buffer-undo-list)
     (ignore-errors (undo))))

(put 'pgg-process-when-success 'lisp-indent-function 0)

(defmacro pgg-process-when-success (&rest body)
  `(with-current-buffer pgg-output-buffer
     (if (zerop (buffer-size)) nil ,@body t)))

(defalias 'pgg-make-temp-file
  (if (fboundp 'make-temp-file)
      'make-temp-file
    (lambda (prefix &optional dir-flag)
      (let ((file (expand-file-name
		   (make-temp-name prefix)
		   (if (fboundp 'temp-directory)
		       (temp-directory)
		     temporary-file-directory))))
	(if dir-flag
	    (make-directory file))
	file))))

;;; @ interface functions
;;;

;;;###autoload
(defun pgg-encrypt-region (start end rcpts &optional sign)
  "Encrypt the current region between START and END for RCPTS.
If optional argument SIGN is non-nil, do a combined sign and encrypt."
  (interactive
   (list (region-beginning)(region-end)
	 (split-string (read-string "Recipients: ") "[ \t,]+")))
  (let ((status
	 (pgg-save-coding-system start end
	   (pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
		       (point-min) (point-max) rcpts sign))))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))

;;;###autoload
(defun pgg-encrypt (rcpts &optional sign start end)
  "Encrypt the current buffer for RCPTS.
If optional argument SIGN is non-nil, do a combined sign and encrypt.
If optional arguments START and END are specified, only encrypt within
the region."
  (interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
  (let* ((start (or start (point-min)))
	 (end (or end (point-max)))
	 (status (pgg-encrypt-region start end rcpts sign)))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))

;;;###autoload
(defun pgg-decrypt-region (start end)
  "Decrypt the current region between START and END."
  (interactive "r")
  (let* ((buf (current-buffer))
	 (status
	  (pgg-save-coding-system start end
	    (pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
			(point-min) (point-max)))))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))

;;;###autoload
(defun pgg-decrypt (&optional start end)
  "Decrypt the current buffer.
If optional arguments START and END are specified, only decrypt within
the region."
  (interactive "")
  (let* ((start (or start (point-min)))
	 (end (or end (point-max)))
	 (status (pgg-decrypt-region start end)))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))

;;;###autoload
(defun pgg-sign-region (start end &optional cleartext)
  "Make the signature from text between START and END.
If the optional 3rd argument CLEARTEXT is non-nil, it does not create
a detached signature.
If this function is called interactively, CLEARTEXT is enabled
and the the output is displayed."
  (interactive "r")
  (let ((status (pgg-save-coding-system start end
		  (pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
			      (point-min) (point-max)
			      (or (interactive-p) cleartext)))))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))

;;;###autoload
(defun pgg-sign (&optional cleartext start end)
  "Sign the current buffer.
If the optional argument CLEARTEXT is non-nil, it does not create a
detached signature.
If optional arguments START and END are specified, only sign data
within the region.
If this function is called interactively, CLEARTEXT is enabled
and the the output is displayed."
  (interactive "")
  (let* ((start (or start (point-min)))
	 (end (or end (point-max)))
	 (status (pgg-sign-region start end (or (interactive-p) cleartext))))
    (when (interactive-p)
      (pgg-display-output-buffer start end status))
    status))
  
;;;###autoload
(defun pgg-verify-region (start end &optional signature fetch)
  "Verify the current region between START and END.
If the optional 3rd argument SIGNATURE is non-nil, it is treated as
the detached signature of the current region.

If the optional 4th argument FETCH is non-nil, we attempt to fetch the
signer's public key from `pgg-default-keyserver-address'."
  (interactive "r")
  (let* ((packet
	  (if (null signature) nil
	    (with-temp-buffer
	      (buffer-disable-undo)
	      (if (fboundp 'set-buffer-multibyte)
		  (set-buffer-multibyte nil))
	      (insert-file-contents signature)
	      (cdr (assq 2 (pgg-decode-armor-region
			    (point-min)(point-max)))))))
	 (key (cdr (assq 'key-identifier packet)))
	 status keyserver)
    (and (stringp key)
	 pgg-query-keyserver
	 (setq key (concat "0x" (pgg-truncate-key-identifier key)))
	 (null (pgg-lookup-key key))
	 (or fetch (interactive-p))
	 (y-or-n-p (format "Key %s not found; attempt to fetch? " key))
	 (setq keyserver
	       (or (cdr (assq 'preferred-key-server packet))
		   pgg-default-keyserver-address))
	 (pgg-fetch-key keyserver key))
    (setq status 
	  (pgg-save-coding-system start end
	    (pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
			(point-min) (point-max) signature)))
    (when (interactive-p)
      (let ((temp-buffer-show-function
	     (function pgg-temp-buffer-show-function)))
	(with-output-to-temp-buffer pgg-echo-buffer
	  (set-buffer standard-output)
	  (insert-buffer-substring (if status pgg-output-buffer
				     pgg-errors-buffer)))))
    status))

;;;###autoload
(defun pgg-verify (&optional signature fetch start end)
  "Verify the current buffer.
If the optional argument SIGNATURE is non-nil, it is treated as
the detached signature of the current region.
If the optional argument FETCH is non-nil, we attempt to fetch the
signer's public key from `pgg-default-keyserver-address'.
If optional arguments START and END are specified, only verify data
within the region."
  (interactive "")
  (let* ((start (or start (point-min)))
	 (end (or end (point-max)))
	 (status (pgg-verify-region start end signature fetch)))
    (when (interactive-p)
      (let ((temp-buffer-show-function
	     (function pgg-temp-buffer-show-function)))
	(with-output-to-temp-buffer pgg-echo-buffer
	  (set-buffer standard-output)
	  (insert-buffer-substring (if status pgg-output-buffer
				     pgg-errors-buffer)))))))

;;;###autoload
(defun pgg-insert-key ()
  "Insert the ASCII armored public key."
  (interactive)
  (pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))

;;;###autoload
(defun pgg-snarf-keys-region (start end)
  "Import public keys in the current region between START and END."
  (interactive "r")
  (pgg-save-coding-system start end
    (pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
		start end)))

;;;###autoload
(defun pgg-snarf-keys ()
  "Import public keys in the current buffer."
  (interactive "")
  (pgg-snarf-keys-region (point-min) (point-max)))

(defun pgg-lookup-key (string &optional type)
  (pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))

(defvar pgg-insert-url-function  (function pgg-insert-url-with-w3))

(defun pgg-insert-url-with-w3 (url)
  (ignore-errors
    (require 'w3)
    (require 'url)
    (let (buffer-file-name)
      (url-insert-file-contents url))))

(defvar pgg-insert-url-extra-arguments nil)
(defvar pgg-insert-url-program nil)

(defun pgg-insert-url-with-program (url)
  (let ((args (copy-sequence pgg-insert-url-extra-arguments))
	process)
    (insert
     (with-temp-buffer
       (setq process
	     (apply #'start-process " *PGG url*" (current-buffer)
		    pgg-insert-url-program (nconc args (list url))))
       (set-process-sentinel process #'ignore)
       (while (eq 'run (process-status process))
	 (accept-process-output process 5))
       (delete-process process)
       (if (and process (eq 'run (process-status process)))
	   (interrupt-process process))
       (buffer-string)))))

(defun pgg-fetch-key (keyserver key)
  "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
  (with-current-buffer (get-buffer-create pgg-output-buffer)
    (buffer-disable-undo)
    (erase-buffer)
    (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
		     (substring keyserver 0 (1- (match-end 0))))))
      (save-excursion
	(funcall pgg-insert-url-function
		 (if proto keyserver
		   (format "http://%s:11371/pks/lookup?op=get&search=%s"
			   keyserver key))))
      (when (re-search-forward "^-+BEGIN" nil 'last)
	(delete-region (point-min) (match-beginning 0))
	(when (re-search-forward "^-+END" nil t)
	  (delete-region (progn (end-of-line) (point))
			 (point-max)))
	(insert "\n")
	(with-temp-buffer
	  (insert-buffer-substring pgg-output-buffer)
	  (pgg-snarf-keys-region (point-min)(point-max)))))))


(provide 'pgg)

;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4
;;; pgg.el ends here
Commit	Line	Data
23f87bed MB	1	;;; pgg.el --- glue for the various PGP implementations.
	2
	3	;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc.
	4
	5	;; Author: Daiki Ueno <ueno@unixuser.org>
	6	;; Created: 1999/10/28
	7	;; Keywords: PGP
	8
	9	;; This file is part of GNU Emacs.
	10
	11	;; GNU Emacs is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation; either version 2, or (at your option)
	14	;; any later version.
	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs; see the file COPYING. If not, write to the
	23	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	24	;; Boston, MA 02111-1307, USA.
	25
	26	;;; Commentary:
	27
	28	;;; Code:
	29
	30	(require 'pgg-def)
	31	(require 'pgg-parse)
	32	(autoload 'run-at-time "timer")
	33
	34	;; Don't merge these two `eval-when-compile's.
	35	(eval-when-compile
	36	(require 'cl))
	37	;; Fixme: This would be better done with an autoload for
	38	;; `url-insert-file-contents', and the url stuff rationalized.
	39	;; (`locate-library' can say whether the url code is available.)
	40	(eval-when-compile
	41	(ignore-errors
	42	(require 'w3)
	43	(require 'url)))
	44
	45	;;; @ utility functions
	46	;;;
	47
	48	(defvar pgg-fetch-key-function (if (fboundp 'url-insert-file-contents)
	49	(function pgg-fetch-key-with-w3)))
	50
	51	(defun pgg-invoke (func scheme &rest args)
	52	(progn
	53	(require (intern (format "pgg-%s" scheme)))
	54	(apply 'funcall (intern (format "pgg-%s-%s" scheme func)) args)))
	55
	56	(put 'pgg-save-coding-system 'lisp-indent-function 2)
	57
	58	(defmacro pgg-save-coding-system (start end &rest body)
	59	`(if (interactive-p)
	60	(let ((buffer (current-buffer)))
	61	(with-temp-buffer
	62	(let (buffer-undo-list)
	63	(insert-buffer-substring buffer ,start ,end)
	64	(encode-coding-region (point-min)(point-max)
65	buffer-file-coding-system)
66	(prog1 (save-excursion ,@body)
67	(push nil buffer-undo-list)
68	(ignore-errors (undo))))))
69	(save-restriction
70	(narrow-to-region ,start ,end)
71	,@body)))
72
73	(defun pgg-temp-buffer-show-function (buffer)
74	(let ((window (or (get-buffer-window buffer 'visible)
75	(split-window-vertically))))
76	(set-window-buffer window buffer)
77	(shrink-window-if-larger-than-buffer window)))
78
79	(defun pgg-display-output-buffer (start end status)
80	(if status
81	(progn
82	(delete-region start end)
83	(insert-buffer-substring pgg-output-buffer)
84	(decode-coding-region start (point) buffer-file-coding-system))
85	(let ((temp-buffer-show-function
86	(function pgg-temp-buffer-show-function)))
87	(with-output-to-temp-buffer pgg-echo-buffer
88	(set-buffer standard-output)
89	(insert-buffer-substring pgg-errors-buffer)))))
90
91	(defvar pgg-passphrase-cache (make-vector 7 0))
92
93	(defun pgg-read-passphrase (prompt &optional key)
94	(or (and pgg-cache-passphrase
95	key (setq key (pgg-truncate-key-identifier key))
96	(symbol-value (intern-soft key pgg-passphrase-cache)))
97	(read-passwd prompt)))
98
99	(eval-when-compile
100	(defvar itimer-process)
101	(defvar itimer-timer)
102	(autoload 'delete-itimer "itimer")
103	(autoload 'itimer-driver-start "itimer")
104	(autoload 'itimer-value "itimer")
105	(autoload 'set-itimer-function "itimer")
106	(autoload 'set-itimer-function-arguments "itimer")
107	(autoload 'set-itimer-restart "itimer")
108	(autoload 'start-itimer "itimer"))
109
110	(eval-and-compile
111	(defalias
112	'pgg-run-at-time
113	(if (featurep 'xemacs)
114	(if (condition-case nil
115	(progn
116	(unless (or itimer-process itimer-timer)
117	(itimer-driver-start))
118	;; Check whether there is a bug to which the difference of
119	;; the present time and the time when the itimer driver was
120	;; woken up is subtracted from the initial itimer value.
121	(let* ((inhibit-quit t)
122	(ctime (current-time))
123	(itimer-timer-last-wakeup
124	(prog1
125	ctime
126	(setcar ctime (1- (car ctime)))))
127	(itimer-list nil)
128	(itimer (start-itimer "pgg-run-at-time" 'ignore 5)))
129	(sleep-for 0.1) ;; Accept the timeout interrupt.
130	(prog1
131	(> (itimer-value itimer) 0)
132	(delete-itimer itimer))))
133	(error nil))
134	(lambda (time repeat function &rest args)
135	"Emulating function run as `run-at-time'.
136	TIME should be nil meaning now, or a number of seconds from now.
137	Return an itimer object which can be used in either `delete-itimer'
138	or `cancel-timer'."
139	(apply #'start-itimer "pgg-run-at-time"
140	function (if time (max time 1e-9) 1e-9)
141	repeat nil t args))
142	(lambda (time repeat function &rest args)
143	"Emulating function run as `run-at-time' in the right way.
144	TIME should be nil meaning now, or a number of seconds from now.
145	Return an itimer object which can be used in either `delete-itimer'
146	or `cancel-timer'."
147	(let ((itimers (list nil)))
148	(setcar
149	itimers
150	(apply #'start-itimer "pgg-run-at-time"
151	(lambda (itimers repeat function &rest args)
152	(let ((itimer (car itimers)))
153	(if repeat
154	(progn
155	(set-itimer-function
156	itimer
157	(lambda (itimer repeat function &rest args)
158	(set-itimer-restart itimer repeat)
159	(set-itimer-function itimer function)
160	(set-itimer-function-arguments itimer args)
161	(apply function args)))
162	(set-itimer-function-arguments
163	itimer
164	(append (list itimer repeat function) args)))
165	(set-itimer-function
166	itimer
167	(lambda (itimer function &rest args)
168	(delete-itimer itimer)
169	(apply function args)))
170	(set-itimer-function-arguments
171	itimer
172	(append (list itimer function) args)))))
173	1e-9 (if time (max time 1e-9) 1e-9)
174	nil t itimers repeat function args)))))
175	'run-at-time)))
176
177	(defun pgg-add-passphrase-cache (key passphrase)
178	(setq key (pgg-truncate-key-identifier key))
179	(set (intern key pgg-passphrase-cache)
180	passphrase)
181	(pgg-run-at-time pgg-passphrase-cache-expiry nil
182	#'pgg-remove-passphrase-cache
183	key))
184
185	(defun pgg-remove-passphrase-cache (key)
186	(let ((passphrase (symbol-value (intern-soft key pgg-passphrase-cache))))
187	(when passphrase
188	(fillarray passphrase ?_)
189	(unintern key pgg-passphrase-cache))))
190
191	(defmacro pgg-convert-lbt-region (start end lbt)
192	`(let ((pgg-conversion-end (set-marker (make-marker) ,end)))
193	(goto-char ,start)
194	(case ,lbt
195	(CRLF
196	(while (progn
197	(end-of-line)
198	(> (marker-position pgg-conversion-end) (point)))
199	(insert "\r")
200	(forward-line 1)))
201	(LF
202	(while (re-search-forward "\r$" pgg-conversion-end t)
203	(replace-match ""))))))
204
205	(put 'pgg-as-lbt 'lisp-indent-function 3)
206
207	(defmacro pgg-as-lbt (start end lbt &rest body)
208	`(let ((inhibit-read-only t)
209	buffer-read-only
210	buffer-undo-list)
211	(pgg-convert-lbt-region ,start ,end ,lbt)
212	(let ((,end (point)))
213	,@body)
214	(push nil buffer-undo-list)
215	(ignore-errors (undo))))
216
217	(put 'pgg-process-when-success 'lisp-indent-function 0)
218
219	(defmacro pgg-process-when-success (&rest body)
220	`(with-current-buffer pgg-output-buffer
221	(if (zerop (buffer-size)) nil ,@body t)))
222
223	(defalias 'pgg-make-temp-file
224	(if (fboundp 'make-temp-file)
225	'make-temp-file
226	(lambda (prefix &optional dir-flag)
227	(let ((file (expand-file-name
228	(make-temp-name prefix)
229	(if (fboundp 'temp-directory)
230	(temp-directory)
231	temporary-file-directory))))
232	(if dir-flag
233	(make-directory file))
234	file))))
235
236	;;; @ interface functions
237	;;;
238
239	;;;###autoload
240	(defun pgg-encrypt-region (start end rcpts &optional sign)
241	"Encrypt the current region between START and END for RCPTS.
242	If optional argument SIGN is non-nil, do a combined sign and encrypt."
243	(interactive
244	(list (region-beginning)(region-end)
245	(split-string (read-string "Recipients: ") "[ \t,]+")))
246	(let ((status
247	(pgg-save-coding-system start end
248	(pgg-invoke "encrypt-region" (or pgg-scheme pgg-default-scheme)
249	(point-min) (point-max) rcpts sign))))
250	(when (interactive-p)
251	(pgg-display-output-buffer start end status))
252	status))
253
254	;;;###autoload
255	(defun pgg-encrypt (rcpts &optional sign start end)
256	"Encrypt the current buffer for RCPTS.
257	If optional argument SIGN is non-nil, do a combined sign and encrypt.
258	If optional arguments START and END are specified, only encrypt within
259	the region."
260	(interactive (list (split-string (read-string "Recipients: ") "[ \t,]+")))
261	(let* ((start (or start (point-min)))
262	(end (or end (point-max)))
263	(status (pgg-encrypt-region start end rcpts sign)))
264	(when (interactive-p)
265	(pgg-display-output-buffer start end status))
266	status))
267
268	;;;###autoload
269	(defun pgg-decrypt-region (start end)
270	"Decrypt the current region between START and END."
271	(interactive "r")
272	(let* ((buf (current-buffer))
273	(status
274	(pgg-save-coding-system start end
275	(pgg-invoke "decrypt-region" (or pgg-scheme pgg-default-scheme)
276	(point-min) (point-max)))))
277	(when (interactive-p)
278	(pgg-display-output-buffer start end status))
279	status))
280
281	;;;###autoload
282	(defun pgg-decrypt (&optional start end)
283	"Decrypt the current buffer.
284	If optional arguments START and END are specified, only decrypt within
285	the region."
286	(interactive "")
287	(let* ((start (or start (point-min)))
288	(end (or end (point-max)))
289	(status (pgg-decrypt-region start end)))
290	(when (interactive-p)
291	(pgg-display-output-buffer start end status))
292	status))
293
294	;;;###autoload
295	(defun pgg-sign-region (start end &optional cleartext)
296	"Make the signature from text between START and END.
297	If the optional 3rd argument CLEARTEXT is non-nil, it does not create
298	a detached signature.
299	If this function is called interactively, CLEARTEXT is enabled
300	and the the output is displayed."
301	(interactive "r")
302	(let ((status (pgg-save-coding-system start end
303	(pgg-invoke "sign-region" (or pgg-scheme pgg-default-scheme)
304	(point-min) (point-max)
305	(or (interactive-p) cleartext)))))
306	(when (interactive-p)
307	(pgg-display-output-buffer start end status))
308	status))
309
310	;;;###autoload
311	(defun pgg-sign (&optional cleartext start end)
312	"Sign the current buffer.
313	If the optional argument CLEARTEXT is non-nil, it does not create a
314	detached signature.
315	If optional arguments START and END are specified, only sign data
316	within the region.
317	If this function is called interactively, CLEARTEXT is enabled
318	and the the output is displayed."
319	(interactive "")
320	(let* ((start (or start (point-min)))
321	(end (or end (point-max)))
322	(status (pgg-sign-region start end (or (interactive-p) cleartext))))
323	(when (interactive-p)
324	(pgg-display-output-buffer start end status))
325	status))
326
327	;;;###autoload
328	(defun pgg-verify-region (start end &optional signature fetch)
329	"Verify the current region between START and END.
330	If the optional 3rd argument SIGNATURE is non-nil, it is treated as
331	the detached signature of the current region.
332
333	If the optional 4th argument FETCH is non-nil, we attempt to fetch the
334	signer's public key from `pgg-default-keyserver-address'."
335	(interactive "r")
336	(let* ((packet
337	(if (null signature) nil
338	(with-temp-buffer
339	(buffer-disable-undo)
340	(if (fboundp 'set-buffer-multibyte)
341	(set-buffer-multibyte nil))
342	(insert-file-contents signature)
343	(cdr (assq 2 (pgg-decode-armor-region
344	(point-min)(point-max)))))))
345	(key (cdr (assq 'key-identifier packet)))
346	status keyserver)
347	(and (stringp key)
348	pgg-query-keyserver
349	(setq key (concat "0x" (pgg-truncate-key-identifier key)))
350	(null (pgg-lookup-key key))
351	(or fetch (interactive-p))
352	(y-or-n-p (format "Key %s not found; attempt to fetch? " key))
353	(setq keyserver
354	(or (cdr (assq 'preferred-key-server packet))
355	pgg-default-keyserver-address))
356	(pgg-fetch-key keyserver key))
357	(setq status
358	(pgg-save-coding-system start end
359	(pgg-invoke "verify-region" (or pgg-scheme pgg-default-scheme)
360	(point-min) (point-max) signature)))
361	(when (interactive-p)
362	(let ((temp-buffer-show-function
363	(function pgg-temp-buffer-show-function)))
364	(with-output-to-temp-buffer pgg-echo-buffer
365	(set-buffer standard-output)
366	(insert-buffer-substring (if status pgg-output-buffer
367	pgg-errors-buffer)))))
368	status))
369
370	;;;###autoload
371	(defun pgg-verify (&optional signature fetch start end)
372	"Verify the current buffer.
373	If the optional argument SIGNATURE is non-nil, it is treated as
374	the detached signature of the current region.
375	If the optional argument FETCH is non-nil, we attempt to fetch the
376	signer's public key from `pgg-default-keyserver-address'.
377	If optional arguments START and END are specified, only verify data
378	within the region."
379	(interactive "")
380	(let* ((start (or start (point-min)))
381	(end (or end (point-max)))
382	(status (pgg-verify-region start end signature fetch)))
383	(when (interactive-p)
384	(let ((temp-buffer-show-function
385	(function pgg-temp-buffer-show-function)))
386	(with-output-to-temp-buffer pgg-echo-buffer
387	(set-buffer standard-output)
388	(insert-buffer-substring (if status pgg-output-buffer
389	pgg-errors-buffer)))))))
390
391	;;;###autoload
392	(defun pgg-insert-key ()
393	"Insert the ASCII armored public key."
394	(interactive)
395	(pgg-invoke "insert-key" (or pgg-scheme pgg-default-scheme)))
396
397	;;;###autoload
398	(defun pgg-snarf-keys-region (start end)
399	"Import public keys in the current region between START and END."
400	(interactive "r")
401	(pgg-save-coding-system start end
402	(pgg-invoke "snarf-keys-region" (or pgg-scheme pgg-default-scheme)
403	start end)))
404
405	;;;###autoload
406	(defun pgg-snarf-keys ()
407	"Import public keys in the current buffer."
408	(interactive "")
409	(pgg-snarf-keys-region (point-min) (point-max)))
410
411	(defun pgg-lookup-key (string &optional type)
412	(pgg-invoke "lookup-key" (or pgg-scheme pgg-default-scheme) string type))
413
414	(defvar pgg-insert-url-function (function pgg-insert-url-with-w3))
415
416	(defun pgg-insert-url-with-w3 (url)
417	(ignore-errors
418	(require 'w3)
419	(require 'url)
420	(let (buffer-file-name)
421	(url-insert-file-contents url))))
422
423	(defvar pgg-insert-url-extra-arguments nil)
424	(defvar pgg-insert-url-program nil)
425
426	(defun pgg-insert-url-with-program (url)
427	(let ((args (copy-sequence pgg-insert-url-extra-arguments))
428	process)
429	(insert
430	(with-temp-buffer
431	(setq process
432	(apply #'start-process " PGG url" (current-buffer)
433	pgg-insert-url-program (nconc args (list url))))
434	(set-process-sentinel process #'ignore)
435	(while (eq 'run (process-status process))
436	(accept-process-output process 5))
437	(delete-process process)
438	(if (and process (eq 'run (process-status process)))
439	(interrupt-process process))
440	(buffer-string)))))
441
442	(defun pgg-fetch-key (keyserver key)
443	"Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring."
444	(with-current-buffer (get-buffer-create pgg-output-buffer)
445	(buffer-disable-undo)
446	(erase-buffer)
447	(let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver)
448	(substring keyserver 0 (1- (match-end 0))))))
449	(save-excursion
450	(funcall pgg-insert-url-function
451	(if proto keyserver
452	(format "http://%s:11371/pks/lookup?op=get&search=%s"
453	keyserver key))))
454	(when (re-search-forward "^-+BEGIN" nil 'last)
455	(delete-region (point-min) (match-beginning 0))
456	(when (re-search-forward "^-+END" nil t)
457	(delete-region (progn (end-of-line) (point))
458	(point-max)))
459	(insert "\n")
460	(with-temp-buffer
461	(insert-buffer-substring pgg-output-buffer)
462	(pgg-snarf-keys-region (point-min)(point-max)))))))
463
464
465	(provide 'pgg)
466
467	;;; arch-tag: 9cc705dd-1e6a-4c90-8dce-c3561f9a2cf4
468	;;; pgg.el ends here