Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ec9a17fef872
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; mc-pgp.el, PGP support for Mailcrypt
2 ;; Copyright (C) 1995 Jin Choi <jin@atype.com>
3 ;; Patrick LoPresti <patl@lcs.mit.edu>
4
5 ;;{{{ Licensing
6 ;; This file is intended to be used with GNU Emacs.
7
8 ;; This program is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; This program is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to
20 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
21 ;;}}}
22 (require 'mailcrypt)
23
24 (defvar mc-pgp-user-id (user-login-name)
25 "*PGP ID of your default identity.")
26 (defvar mc-pgp-always-sign nil
27 "*If t, always sign encrypted PGP messages, or never sign if 'never.")
28 (defvar mc-pgp-path "pgp" "*The PGP executable.")
29 (defvar mc-pgp-display-snarf-output nil
30 "*If t, pop up the PGP output window when snarfing keys.")
31 (defvar mc-pgp-alternate-keyring nil
32 "*Public keyring to use instead of default.")
33 (defvar mc-pgp-comment
34 (format "Processed by Mailcrypt %s, an Emacs/PGP interface" mc-version)
35 "*Comment field to appear in ASCII armor output. If nil, let PGP
36 use its default.")
37
38 (defconst mc-pgp-msg-begin-line "-----BEGIN PGP MESSAGE-----"
39 "Text for start of PGP message delimiter.")
40 (defconst mc-pgp-msg-end-line "-----END PGP MESSAGE-----\n?"
41 "Text for end of PGP message delimiter.")
42 (defconst mc-pgp-signed-begin-line "-----BEGIN PGP SIGNED MESSAGE-----"
43 "Text for start of PGP signed messages.")
44 (defconst mc-pgp-signed-end-line "-----END PGP SIGNATURE-----"
45 "Text for end of PGP signed messages.")
46 (defconst mc-pgp-key-begin-line "^-----BEGIN PGP PUBLIC KEY BLOCK-----\r?$"
47 "Text for start of PGP public key.")
48 (defconst mc-pgp-key-end-line "^-----END PGP PUBLIC KEY BLOCK-----\r?$"
49 "Text for end of PGP public key.")
50 (defconst mc-pgp-error-re "^\\(ERROR:\\|WARNING:\\).*"
51 "Regular expression matching an error from PGP")
52 (defconst mc-pgp-sigok-re "^.*Good signature.*"
53 "Regular expression matching a PGP signature validation message")
54 (defconst mc-pgp-newkey-re "^[ \t]*\\(No\\|[0-9]+\\) +new [ku].*"
55 "Regular expression matching a PGP key snarf message")
56 (defconst mc-pgp-nokey-re
57 "Cannot find the public key matching userid '\\(.+\\)'$"
58 "Regular expression matching a PGP missing-key messsage")
59 (defconst mc-pgp-key-expected-re
60 "Key matching expected Key ID \\(\\S +\\) not found")
61
62 (defvar mc-pgp-keydir nil
63 "Directory in which keyrings are stored.")
64
65 (defun mc-get-pgp-keydir ()
66 (if (null mc-pgp-keydir)
67 (let ((buffer (generate-new-buffer " *mailcrypt temp*"))
68 (obuf (current-buffer)))
69 (unwind-protect
70 (progn
71 (call-process mc-pgp-path nil buffer nil "+verbose=1"
72 "+language=en" "-kv" "XXXXXXXXXX")
73 (set-buffer buffer)
74 (goto-char (point-min))
75 (re-search-forward "^Key ring:\\s *'\\(.*\\)'")
76 (setq mc-pgp-keydir
77 (file-name-directory
78 (buffer-substring-no-properties
79 (match-beginning 1) (match-end 1)))))
80 (set-buffer obuf)
81 (kill-buffer buffer))))
82 mc-pgp-keydir)
83
84 (defvar mc-pgp-key-cache nil
85 "Association list mapping PGP IDs to canonical \"keys\". A \"key\"
86 is a pair (USER-ID . KEY-ID) which identifies the canonical IDs of the
87 PGP ID.")
88
89 (defun mc-pgp-lookup-key (str)
90 ;; Look up the string STR in the user's secret key ring. Return a
91 ;; pair of strings (USER-ID . KEY-ID) which uniquely identifies the
92 ;; matching key, or nil if no key matches.
93 (if (equal str "***** CONVENTIONAL *****") nil
94 (let ((keyring (concat (mc-get-pgp-keydir) "secring"))
95 (result (cdr-safe (assoc str mc-pgp-key-cache)))
96 (key-regexp
97 "^\\(pub\\|sec\\)\\s +[^/]+/\\(\\S *\\)\\s +\\S +\\s +\\(.*\\)$")
98 (obuf (current-buffer))
99 buffer)
100 (if (null result)
101 (unwind-protect
102 (progn
103 (setq buffer (generate-new-buffer " *mailcrypt temp"))
104 (call-process mc-pgp-path nil buffer nil
105 "+language=en" "-kv" str keyring)
106 (set-buffer buffer)
107 (goto-char (point-min))
108 (if (re-search-forward key-regexp nil t)
109 (progn
110 (setq result
111 (cons (buffer-substring-no-properties
112 (match-beginning 3) (match-end 3))
113 (concat
114 "0x"
115 (buffer-substring-no-properties
116 (match-beginning 2) (match-end 2)))))
117 (setq mc-pgp-key-cache (cons (cons str result)
118 mc-pgp-key-cache)))))
119 (if buffer (kill-buffer buffer))
120 (set-buffer obuf)))
121 (if (null result)
122 (error "No PGP secret key for %s" str))
123 result)))
124
125 (defun mc-pgp-generic-parser (result)
126 (let (start)
127 (goto-char (point-min))
128 (cond ((not (eq result 0))
129 (prog1
130 nil
131 (if (mc-message "^\aError: +Bad pass phrase\\.$" (current-buffer))
132 (mc-deactivate-passwd t)
133 (mc-message mc-pgp-error-re (current-buffer)
134 (format "PGP exited with status %d" result)))))
135 ((re-search-forward mc-pgp-nokey-re nil t)
136 nil)
137 (t
138 (and
139 (goto-char (point-min))
140 (re-search-forward "-----BEGIN PGP.*-----$" nil t)
141 (setq start (match-beginning 0))
142 (goto-char (point-max))
143 (re-search-backward "^-----END PGP.*-----\n" nil t)
144 (cons start (match-end 0)))))))
145
146 (defun mc-pgp-encrypt-region (recipients start end &optional id sign)
147 (let ((process-environment process-environment)
148 (buffer (get-buffer-create mc-buffer-name))
149 ;; Crock. Rewrite someday.
150 (mc-pgp-always-sign mc-pgp-always-sign)
151 (obuf (current-buffer))
152 action msg args key passwd result pgp-id)
153 (setq args (list "+encrypttoself=off +verbose=1" "+batchmode"
154 "+language=en" "-fat"))
155 (setq action (if recipients "Encrypting" "Armoring"))
156 (setq msg (format "%s..." action)) ; May get overridden below
157 (if recipients (setq args (cons "-e" args)))
158 (if mc-pgp-comment
159 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
160 (if mc-pgp-alternate-keyring
161 (setq args (append args (list (format "+pubring=%s"
162 mc-pgp-alternate-keyring)))))
163 (if (and (not (eq mc-pgp-always-sign 'never))
164 (or mc-pgp-always-sign sign (y-or-n-p "Sign the message? ")))
165 (progn
166 (setq mc-pgp-always-sign t)
167 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
168 (setq passwd
169 (mc-activate-passwd
170 (cdr key)
171 (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
172 (setq args
173 (nconc args (list "-s" "-u" (cdr key))))
174 (setenv "PGPPASSFD" "0")
175 (setq msg (format "%s+signing as %s ..." action (car key))))
176 (setq mc-pgp-always-sign 'never))
177
178 (or key
179 (setq key (mc-pgp-lookup-key mc-pgp-user-id)))
180
181 (if (and recipients mc-encrypt-for-me)
182 (setq recipients (cons (cdr key) recipients)))
183
184 (setq args (append args recipients))
185
186 (message "%s" msg)
187 (setq result (mc-process-region start end passwd mc-pgp-path args
188 'mc-pgp-generic-parser buffer))
189 (save-excursion
190 (set-buffer buffer)
191 (goto-char (point-min))
192 (if (re-search-forward mc-pgp-nokey-re nil t)
193 (progn
194 (if result (error "This should never happen."))
195 (setq pgp-id (buffer-substring-no-properties
196 (match-beginning 1) (match-end 1)))
197 (if (and (not (eq mc-pgp-always-fetch 'never))
198 (or mc-pgp-always-fetch
199 (y-or-n-p
200 (format "Key for '%s' not found; try to fetch? "
201 pgp-id))))
202 (progn
203 (mc-pgp-fetch-key (cons pgp-id nil))
204 (set-buffer obuf)
205 (mc-pgp-encrypt-region recipients start end id))
206 (mc-message mc-pgp-nokey-re buffer)
207 nil))
208 (if (not result)
209 nil
210 (message "%s Done." msg)
211 t)))))
212
213 (defun mc-pgp-decrypt-parser (result)
214 (goto-char (point-min))
215 (cond ((eq result 0)
216 ;; Valid signature
217 (re-search-forward "^Signature made.*\n")
218 (if (looking-at
219 "\a\nWARNING: Because this public key.*\n.*\n.*\n")
220 (goto-char (match-end 0)))
221 (cons (point) (point-max)))
222 ((eq result 1)
223 (re-search-forward
224 "\\(\\(^File is conven.*\\)?Just a moment\\.+\\)\\|\\(^\\.\\)")
225 (if (eq (match-beginning 2) (match-end 2))
226 (if (looking-at
227 "\nFile has signature.*\\(\n\a.*\n\\)*\nWARNING:.*\n")
228 (goto-char (match-end 0)))
229 (if (looking-at "Pass phrase appears good\\. \\.")
230 (goto-char (match-end 0))))
231 (cons (point) (point-max)))
232 (t nil)))
233
234 (defun mc-pgp-decrypt-region (start end &optional id)
235 ;; returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if
236 ;; the decryption succeeded and verified is t if there was a valid signature
237 (let ((process-environment process-environment)
238 (buffer (get-buffer-create mc-buffer-name))
239 args key new-key passwd result pgp-id)
240 (undo-boundary)
241 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
242 (setq
243 passwd
244 (if key
245 (mc-activate-passwd (cdr key)
246 (and id
247 (format "PGP passphrase for %s (%s): "
248 (car key) (cdr key))))
249 (mc-activate-passwd id "PGP passphrase for conventional decryption: ")))
250 (if passwd
251 (setenv "PGPPASSFD" "0"))
252 (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
253 (if mc-pgp-alternate-keyring
254 (setq args (append args (list (format "+pubring=%s"
255 mc-pgp-alternate-keyring)))))
256 (message "Decrypting...")
257 (setq result
258 (mc-process-region
259 start end passwd mc-pgp-path args 'mc-pgp-decrypt-parser buffer))
260 (cond
261 (result
262 (message "Decrypting... Done.")
263 ;; If verification failed due to missing key, offer to fetch it.
264 (save-excursion
265 (set-buffer buffer)
266 (goto-char (point-min))
267 (if (re-search-forward mc-pgp-key-expected-re nil t)
268 (setq pgp-id (concat "0x" (buffer-substring-no-properties
269 (match-beginning 1)
270 (match-end 1))))))
271 (if (and pgp-id
272 (not (eq mc-pgp-always-fetch 'never))
273 (or mc-pgp-always-fetch
274 (y-or-n-p
275 (format "Key %s not found; attempt to fetch? " pgp-id)))
276 (mc-pgp-fetch-key (cons nil pgp-id)))
277 (progn
278 (undo-start)
279 (undo-more 1)
280 (mc-pgp-decrypt-region start end id))
281 (mc-message mc-pgp-key-expected-re buffer)
282 (cons t (eq result 0))))
283 ;; Decryption failed; maybe we need to use a different user-id
284 ((save-excursion
285 (and
286 (set-buffer buffer)
287 (goto-char (point-min))
288 (re-search-forward
289 "^Key for user ID:.*\n.*Key ID \\([0-9A-F]+\\)" nil t)
290 (setq new-key
291 (mc-pgp-lookup-key
292 (concat "0x" (buffer-substring-no-properties
293 (match-beginning 1)
294 (match-end 1)))))
295 (not (and id (equal key new-key)))))
296 (mc-pgp-decrypt-region start end (cdr new-key)))
297 ;; Or maybe it is conventionally encrypted
298 ((save-excursion
299 (and
300 (set-buffer buffer)
301 (goto-char (point-min))
302 (re-search-forward "^File is conventionally encrypted" nil t)))
303 (if (null key) (mc-deactivate-passwd t))
304 (mc-pgp-decrypt-region start end "***** CONVENTIONAL *****"))
305 (t
306 (mc-display-buffer buffer)
307 (if (mc-message "^\aError: +Bad pass phrase\\.$" buffer)
308 (mc-deactivate-passwd t)
309 (mc-message mc-pgp-error-re buffer "Error decrypting buffer"))
310 (cons nil nil)))))
311
312 (defun mc-pgp-sign-region (start end &optional id unclear)
313 (let ((process-environment process-environment)
314 (buffer (get-buffer-create mc-buffer-name))
315 passwd args key)
316 (setq key (mc-pgp-lookup-key (or id mc-pgp-user-id)))
317 (setq passwd
318 (mc-activate-passwd
319 (cdr key)
320 (format "PGP passphrase for %s (%s): " (car key) (cdr key))))
321 (setenv "PGPPASSFD" "0")
322 (setq args
323 (list
324 "-fast" "+verbose=1" "+language=en"
325 (format "+clearsig=%s" (if unclear "off" "on"))
326 "+batchmode" "-u" (cdr key)))
327 (if mc-pgp-comment
328 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
329 (message "Signing as %s ..." (car key))
330 (if (mc-process-region start end passwd mc-pgp-path args
331 'mc-pgp-generic-parser buffer)
332 (progn
333 (message "Signing as %s ... Done." (car key))
334 t)
335 nil)))
336
337 (defun mc-pgp-verify-parser (result)
338 (cond ((eq result 0)
339 (mc-message mc-pgp-sigok-re (current-buffer) "Good signature")
340 t)
341 ((eq result 1)
342 (mc-message mc-pgp-error-re (current-buffer) "Bad signature")
343 nil)
344 (t
345 (mc-message mc-pgp-error-re (current-buffer)
346 (format "PGP exited with status %d" result))
347 nil)))
348
349 (defun mc-pgp-verify-region (start end &optional no-fetch)
350 (let ((buffer (get-buffer-create mc-buffer-name))
351 (obuf (current-buffer))
352 args pgp-id)
353 (setq args '("+verbose=1" "+batchmode" "+language=en" "-f"))
354 (if mc-pgp-alternate-keyring
355 (setq args (append args (list (format "+pubring=%s"
356 mc-pgp-alternate-keyring)))))
357 (message "Verifying...")
358 (if (mc-process-region
359 start end nil mc-pgp-path args 'mc-pgp-verify-parser buffer)
360 t
361 (save-excursion
362 (set-buffer buffer)
363 (goto-char (point-min))
364 (if (and
365 (not no-fetch)
366 (re-search-forward mc-pgp-key-expected-re nil t)
367 (setq pgp-id
368 (concat "0x" (buffer-substring-no-properties
369 (match-beginning 1)
370 (match-end 1))))
371 (not (eq mc-pgp-always-fetch 'never))
372 (or mc-pgp-always-fetch
373 (y-or-n-p
374 (format "Key %s not found; attempt to fetch? " pgp-id)))
375 (mc-pgp-fetch-key (cons nil pgp-id))
376 (set-buffer obuf))
377 (mc-pgp-verify-region start end t)
378 (mc-message mc-pgp-error-re buffer)
379 nil)))))
380
381 (defun mc-pgp-insert-public-key (&optional id)
382 (let ((buffer (get-buffer-create mc-buffer-name))
383 args)
384 (setq id (or id mc-pgp-user-id))
385 (setq args (list "+verbose=1" "+batchmode" "+language=en" "-kxaf" id))
386 (if mc-pgp-comment
387 (setq args (cons (format "+comment=%s" mc-pgp-comment) args)))
388 (if mc-pgp-alternate-keyring
389 (setq args (append args (list (format "+pubring=%s"
390 mc-pgp-alternate-keyring)))))
391
392 (if (mc-process-region (point) (point) nil mc-pgp-path
393 args 'mc-pgp-generic-parser buffer)
394 (progn
395 (mc-message "Key for user ID: .*" buffer)
396 t))))
397
398 (defun mc-pgp-snarf-parser (result)
399 (eq result 0))
400
401 (defun mc-pgp-snarf-keys (start end)
402 ;; Returns number of keys found.
403 (let ((buffer (get-buffer-create mc-buffer-name)) tmpstr args)
404 (setq args '("+verbose=1" "+batchmode" "+language=en" "-kaf"))
405 (if mc-pgp-alternate-keyring
406 (setq args (append args (list (format "+pubring=%s"
407 mc-pgp-alternate-keyring)))))
408 (message "Snarfing...")
409 (if (mc-process-region start end nil mc-pgp-path args
410 'mc-pgp-snarf-parser buffer)
411 (save-excursion
412 (set-buffer buffer)
413 (goto-char (point-min))
414 (if (re-search-forward mc-pgp-newkey-re nil t)
415 (progn
416 (if mc-pgp-display-snarf-output (mc-display-buffer buffer))
417 (setq tmpstr (buffer-substring-no-properties
418 (match-beginning 1)
419 (match-end 1)))
420 (if (equal tmpstr "No")
421 0
422 (car (read-from-string tmpstr))))))
423 (mc-display-buffer buffer)
424 (mc-message mc-pgp-error-re buffer "Error snarfing PGP keys")
425 0)))
426
427 ;;;###autoload
428 (defun mc-scheme-pgp ()
429 (list
430 (cons 'encryption-func 'mc-pgp-encrypt-region)
431 (cons 'decryption-func 'mc-pgp-decrypt-region)
432 (cons 'signing-func 'mc-pgp-sign-region)
433 (cons 'verification-func 'mc-pgp-verify-region)
434 (cons 'key-insertion-func 'mc-pgp-insert-public-key)
435 (cons 'snarf-func 'mc-pgp-snarf-keys)
436 (cons 'msg-begin-line mc-pgp-msg-begin-line)
437 (cons 'msg-end-line mc-pgp-msg-end-line)
438 (cons 'signed-begin-line mc-pgp-signed-begin-line)
439 (cons 'signed-end-line mc-pgp-signed-end-line)
440 (cons 'key-begin-line mc-pgp-key-begin-line)
441 (cons 'key-end-line mc-pgp-key-end-line)
442 (cons 'user-id mc-pgp-user-id)))
443
444 ;;{{{ Key fetching
445
446 (defvar mc-pgp-always-fetch nil
447 "*If t, always attempt to fetch missing keys, or never fetch if
448 'never.")
449
450 (defvar mc-pgp-keyserver-url-template
451 "/htbin/pks-extract-key.pl?op=get&search=%s"
452 "The URL to pass to the keyserver.")
453
454 (defvar mc-pgp-keyserver-address "pgp.ai.mit.edu"
455 "Host name of keyserver.")
456
457 (defvar mc-pgp-keyserver-port 80
458 "Port on which the keyserver's HTTP daemon lives.")
459
460 (defvar mc-pgp-fetch-timeout 20
461 "*Timeout, in seconds, for any particular key fetch operation.")
462
463 (defvar mc-pgp-fetch-keyring-list nil
464 "*List of strings which are filenames of public keyrings to search
465 when fetching keys.")
466
467 (defsubst mc-pgp-buffer-get-key (buf)
468 "Return the first key block in BUF as a string, or nil if none found."
469 (save-excursion
470 (let (start)
471 (set-buffer buf)
472 (goto-char (point-min))
473 (and (re-search-forward mc-pgp-key-begin-line nil t)
474 (setq start (match-beginning 0))
475 (re-search-forward mc-pgp-key-end-line nil t)
476 (buffer-substring-no-properties start (match-end 0))))))
477
478 (defun mc-pgp-fetch-from-keyrings (id)
479 (let ((keyring-list mc-pgp-fetch-keyring-list)
480 buf proc key)
481 (unwind-protect
482 (progn
483 (message "Fetching %s from keyrings..." (or (cdr id) (car id)))
484 (while (and (not key) keyring-list)
485 (setq buf (generate-new-buffer " *mailcrypt temp*"))
486 (setq proc
487 (start-process "*PGP*" buf mc-pgp-path "-kxaf"
488 "+verbose=0" "+batchmode"
489 (format "+pubring=%s" (car keyring-list))
490 (or (cdr id) (car id))))
491 ;; Because PGPPASSFD might be set
492 (process-send-string proc "\r\n")
493 (while (eq 'run (process-status proc))
494 (accept-process-output proc 5))
495 (setq key (mc-pgp-buffer-get-key buf))
496 (setq keyring-list (cdr keyring-list)))
497 key)
498 (if buf (kill-buffer buf))
499 (if (and proc (eq 'run (process-status proc)))
500 (interrupt-process proc)))))
501
502 (defun mc-pgp-fetch-from-http (id)
503 (let (buf connection)
504 (unwind-protect
505 (progn
506 (message "Fetching %s via HTTP to %s..."
507 (or (cdr id) (car id)) mc-pgp-keyserver-address)
508 (setq buf (generate-new-buffer " *mailcrypt temp*"))
509 (setq connection
510 (open-network-stream "*key fetch*" buf mc-pgp-keyserver-address
511 mc-pgp-keyserver-port))
512 (process-send-string
513 connection
514 (concat "GET " (format mc-pgp-keyserver-url-template
515 (or (cdr id) (car id))) "\r\n"))
516 (while (and (eq 'open (process-status connection))
517 (accept-process-output connection mc-pgp-fetch-timeout)))
518 (mc-pgp-buffer-get-key buf))
519 (if buf (kill-buffer buf))
520 (if connection (delete-process connection)))))
521
522 (defun mc-pgp-fetch-from-finger (id)
523 (let (buf connection user host)
524 (unwind-protect
525 (and (car id)
526 (string-match "^\\(.+\\)@\\([^@]+\\)$" (car id))
527 (progn
528 (message "Trying finger %s..." (car id))
529 (setq user (substring (car id)
530 (match-beginning 1) (match-end 1)))
531 (setq host (substring (car id)
532 (match-beginning 2) (match-end 2)))
533 (setq buf (generate-new-buffer " *mailcrypt temp*"))
534 (condition-case nil
535 (progn
536 (setq connection
537 (open-network-stream "*key fetch*" buf host 79))
538 (process-send-string connection
539 (concat "/W " user "\r\n"))
540 (while
541 (and (eq 'open (process-status connection))
542 (accept-process-output connection
543 mc-pgp-fetch-timeout)))
544 (mc-pgp-buffer-get-key buf))
545 (error nil))))
546 (if buf (kill-buffer buf))
547 (if connection (delete-process connection)))))
548
549 (defvar mc-pgp-fetch-methods '(mc-pgp-fetch-from-keyrings
550 mc-pgp-fetch-from-finger
551 mc-pgp-fetch-from-http)
552 "List of methods to try when attempting to fetch a key. Each
553 element is a function to call with an ID as argument. See the
554 documentation for the function mc-pgp-fetch-key for a description of
555 the ID.")
556
557 ;;;###autoload
558 (defun mc-pgp-fetch-key (&optional id)
559 "Attempt to fetch a key for addition to PGP keyring. Interactively,
560 prompt for string matching key to fetch.
561
562 Non-interactively, ID must be a pair. The CAR must be a bare Email
563 address and the CDR a keyID (with \"0x\" prefix). Either, but not
564 both, may be nil.
565
566 Return t if we think we were successful; nil otherwise. Note that nil
567 is not necessarily an error, since we may have merely fired off an Email
568 request for the key."
569 (interactive)
570 (let ((methods mc-pgp-fetch-methods)
571 (process-connection-type nil) key proc buf args)
572 (if (null id)
573 (setq id (cons (read-string "Fetch key for: ") nil)))
574 (while (and (not key) methods)
575 (setq key (funcall (car methods) id))
576 (setq methods (cdr methods)))
577 (if (not (stringp key))
578 (progn
579 (message "Key not found.")
580 nil)
581 ;; Maybe I'll do this right someday.
582 (unwind-protect
583 (save-window-excursion
584 (setq buf (generate-new-buffer " *PGP Key Info*"))
585 (pop-to-buffer buf)
586 (if (< (window-height) (/ (frame-height) 2))
587 (enlarge-window (- (/ (frame-height) 2)
588 (window-height))))
589 (setq args '("-f" "+verbose=0" "+batchmode"))
590 (if mc-pgp-alternate-keyring
591 (setq args
592 (append args (list (format "+pubring=%s"
593 mc-pgp-alternate-keyring)))))
594
595 (setq proc (apply 'start-process "*PGP*" buf mc-pgp-path args))
596 ;; Because PGPPASSFD might be set
597 (process-send-string proc "\r\n")
598 (process-send-string proc key)
599 (process-send-string proc "\r\n")
600 (process-send-eof proc)
601 (set-buffer buf)
602 (while (eq 'run (process-status proc))
603 (accept-process-output proc 5)
604 (goto-char (point-min)))
605 (if (y-or-n-p "Add this key to keyring? ")
606 (progn
607 (setq args (append args '("-ka")))
608 (setq proc
609 (apply 'start-process "*PGP*" buf mc-pgp-path args))
610 ;; Because PGPPASSFD might be set
611 (process-send-string proc "\r\n")
612 (process-send-string proc key)
613 (process-send-string proc "\r\n")
614 (process-send-eof proc)
615 (while (eq 'run (process-status proc))
616 (accept-process-output proc 5))
617 t)))
618 (if buf (kill-buffer buf))))))
619
620 ;;}}}