Mercurial > hg > xemacs-beta

comparison lisp/mailcrypt/mc-toplev.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 ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; mc-toplev.el, entry point functions for Mailcrypt
2 ;; Copyright (C) 1995 Jin Choi <jsc@mit.edu>
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 ;;{{{ Load some required packages
23 (require 'mailcrypt)
24 (require 'mail-utils)
25
26 (eval-when-compile
27 ;; RMAIL
28 (condition-case nil (require 'rmail) (error nil))
29 (autoload 'rmail-abort-edit "rmailedit")
30 (autoload 'rmail-cease-edit "rmailedit")
31 ;; Is this a good idea?
32 (defvar rmail-buffer nil)
33
34 ;; VM
35 (condition-case nil (require 'vm) (error nil))
36
37 ;; GNUS
38 (condition-case nil (require 'gnus) (error nil))
39
40 ;; MH-E
41 (condition-case nil (require 'mh-e) (error nil)))
42
43 (eval-and-compile
44 (condition-case nil (require 'mailalias) (error nil)))
45
46 (if (not mc-xemacs-p)
47 (autoload 'mc-scheme-pgp "mc-pgp" nil t))
48
49 ;;}}}
50
51 ;;{{{ Encryption
52
53 ;;;###autoload
54 (defun mc-cleanup-recipient-headers (str)
55 ;; Takes a comma separated string of recipients to encrypt for and,
56 ;; assuming they were possibly extracted from the headers of a reply,
57 ;; returns a list of the address components.
58 (mapcar 'mc-strip-address
59 (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" str)))
60
61 (defun mc-find-headers-end ()
62 (save-excursion
63 (goto-char (point-min))
64 (re-search-forward
65 (concat "^" (regexp-quote mail-header-separator) "\n"))
66 (if (looking-at "^::\n")
67 (re-search-forward "^\n" nil t))
68 (if (looking-at "^##\n")
69 (re-search-forward "^\n" nil t))
70 (point-marker)))
71
72 ;;;###autoload
73 (defun mc-encrypt (arg)
74 "*Encrypt the current buffer.
75
76 Exact behavior depends on current major mode.
77
78 With \\[universal-argument], prompt for User ID to sign as.
79
80 With \\[universal-argument] \\[universal-argument], prompt for encryption scheme to use."
81 (interactive "p")
82 (mc-encrypt-region arg nil nil))
83
84 (defun mc-encrypt-region (arg start end)
85 "*Encrypt the current region."
86 (interactive "p\nr")
87 (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist)))
88 (func (or (cdr-safe (assq 'encrypt mode-alist))
89 'mc-encrypt-generic))
90 sign scheme from)
91 (if (>= arg 4)
92 (setq from (read-string "User ID: ")
93 sign t))
94 (if (>= arg 16)
95 (setq scheme
96 (cdr (assoc
97 (completing-read "Encryption Scheme: " mc-schemes)
98 mc-schemes))))
99 (funcall func nil scheme start end from sign)))
100
101 (defun mc-encrypt-generic (&optional recipients scheme start end from sign)
102 "*Generic function to encrypt a region of data."
103 (save-excursion
104 (or start (setq start (point-min-marker)))
105 (or (markerp start) (setq start (copy-marker start)))
106 (or end (setq end (point-max-marker)))
107 (or (markerp end) (setq end (copy-marker end)))
108 (run-hooks 'mc-pre-encryption-hook)
109 (cond ((stringp recipients)
110 (setq recipients
111 (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)))
112 ((null recipients)
113 (setq recipients
114 (mc-cleanup-recipient-headers (read-string "Recipients: "))))
115 (t (error "mc-encrypt-generic: recipients not string or nil")))
116 (or scheme (setq scheme mc-default-scheme))
117 (if (funcall (cdr (assoc 'encryption-func (funcall scheme)))
118 recipients start end from sign)
119 (progn
120 (run-hooks 'mc-post-encryption-hook)
121 t))))
122
123 ;;;###autoload
124 (defun mc-encrypt-message (&optional recipients scheme start end from sign)
125 "*Encrypt a message for RECIPIENTS using the given encryption SCHEME.
126 RECIPIENTS is a comma separated string. If SCHEME is nil, use the value
127 of `mc-default-scheme'. Returns t on success, nil otherwise."
128 (save-excursion
129 (let ((headers-end (mc-find-headers-end))
130 default-recipients)
131
132 (setq default-recipients
133 (save-restriction
134 (goto-char (point-min))
135 (re-search-forward
136 (concat "^" (regexp-quote mail-header-separator) "$"))
137 (narrow-to-region (point-min) (point))
138 (and (featurep 'mailalias)
139 (not (featurep 'mail-abbrevs))
140 mail-aliases
141 (expand-mail-aliases (point-min) (point-max)))
142 (mc-strip-addresses
143 (mapcar 'cdr
144 (mc-get-fields "to\\|cc\\|bcc")))))
145
146 (if (not from)
147 (save-restriction
148 (goto-char (point-min))
149 (re-search-forward
150 (concat "^" (regexp-quote mail-header-separator) "\n"))
151 (narrow-to-region (point) headers-end)
152 (setq from (mail-fetch-field "From"))))
153
154 (if (not recipients)
155 (setq recipients
156 (if mc-use-default-recipients
157 default-recipients
158 (read-from-minibuffer "Recipients: " default-recipients))))
159
160 (or start (setq start headers-end))
161 (or end (setq end (point-max-marker)))
162
163 (mc-encrypt-generic recipients scheme start end from sign))))
164
165
166 ;;}}}
167 ;;{{{ Decryption
168
169 ;;;###autoload
170 (defun mc-decrypt ()
171 "*Decrypt a message in the current buffer.
172
173 Exact behavior depends on current major mode."
174 (interactive)
175 (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist)))
176 (func (or (cdr-safe (assq 'decrypt mode-alist))
177 'mc-decrypt-message)))
178 (funcall func)))
179
180 ;;;###autoload
181 (defun mc-decrypt-message ()
182 "Decrypt whatever message is in the current buffer.
183 Returns a pair (SUCCEEDED . VERIFIED) where SUCCEEDED is t if the encryption
184 succeeded and VERIFIED is t if it had a valid signature."
185 (save-excursion
186 (let ((schemes mc-schemes)
187 limits scheme)
188 (while (and schemes
189 (setq scheme (cdr (car schemes)))
190 (not (setq
191 limits
192 (mc-message-delimiter-positions
193 (cdr (assoc 'msg-begin-line (funcall scheme)))
194 (cdr (assoc 'msg-end-line (funcall scheme)))))))
195 (setq schemes (cdr schemes)))
196
197 (if (null limits)
198 (error "Found no encrypted message in this buffer.")
199 (run-hooks 'mc-pre-decryption-hook)
200 (let ((resultval (funcall (cdr (assoc 'decryption-func
201 (funcall scheme)))
202 (car limits) (cdr limits))))
203 (goto-char (point-min))
204 (if (car resultval) ; decryption succeeded
205 (run-hooks 'mc-post-decryption-hook))
206 resultval)))))
207 ;;}}}
208 ;;{{{ Signing
209 ;;;###autoload
210 (defun mc-sign (arg)
211 "*Sign a message in the current buffer.
212
213 Exact behavior depends on current major mode.
214
215 With one prefix arg, prompts for private key to use, with two prefix args,
216 also prompts for encryption scheme to use. With negative prefix arg,
217 inhibits clearsigning (pgp)."
218 (interactive "p")
219 (mc-sign-region arg nil nil))
220
221 (defun mc-sign-region (arg start end)
222 "*Sign the current region."
223 (interactive "p\nr")
224 (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist)))
225 (func (or (cdr-safe (assq 'sign mode-alist))
226 'mc-sign-generic))
227 from scheme)
228 (if (>= arg 16)
229 (setq scheme
230 (cdr (assoc
231 (completing-read "Encryption Scheme: " mc-schemes)
232 mc-schemes))))
233 (if (>= arg 4)
234 (setq from (read-string "User ID: ")))
235
236 (funcall func from scheme start end (< arg 0))))
237
238 (defun mc-sign-generic (withkey scheme start end unclearsig)
239 (or scheme (setq scheme mc-default-scheme))
240 (or start (setq start (point-min-marker)))
241 (or (markerp start) (setq start (copy-marker start)))
242 (or end (setq end (point-max-marker)))
243 (or (markerp end) (setq end (copy-marker end)))
244 (run-hooks 'mc-pre-signature-hook)
245 (if (funcall (cdr (assoc 'signing-func (funcall scheme)))
246 start end withkey unclearsig)
247 (progn
248 (run-hooks 'mc-post-signature-hook)
249 t)))
250
251 ;;;###autoload
252 (defun mc-sign-message (&optional withkey scheme start end unclearsig)
253 "Clear sign the message."
254 (save-excursion
255 (let ((headers-end (mc-find-headers-end)))
256 (or withkey
257 (progn
258 (goto-char (point-min))
259 (re-search-forward
260 (concat "^" (regexp-quote mail-header-separator) "\n"))
261 (save-restriction
262 (narrow-to-region (point) headers-end)
263 (setq withkey (mail-fetch-field "From")))))
264 (or start (setq start headers-end))
265 (or end (setq end (point-max-marker)))
266 (mc-sign-generic withkey scheme start end unclearsig))))
267
268 ;;}}}
269 ;;{{{ Signature verification
270
271 ;;;###autoload
272 (defun mc-verify ()
273 "*Verify a message in the current buffer.
274
275 Exact behavior depends on current major mode."
276 (interactive)
277 (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist)))
278 (func (or (cdr-safe (assq 'verify mode-alist))
279 'mc-verify-signature)))
280 (funcall func)))
281
282 ;;;###autoload
283 (defun mc-verify-signature ()
284 "*Verify the signature of the signed message in the current buffer.
285 Show the result as a message in the minibuffer. Returns t if the signature
286 is verified."
287 (save-excursion
288 (let ((schemes mc-schemes)
289 limits scheme)
290 (while (and schemes
291 (setq scheme (cdr (car schemes)))
292 (not
293 (setq
294 limits
295 (mc-message-delimiter-positions
296 (cdr (assoc 'signed-begin-line (funcall scheme)))
297 (cdr (assoc 'signed-end-line (funcall scheme)))))))
298 (setq schemes (cdr schemes)))
299
300 (if (null limits)
301 (error "Found no signed message in this buffer.")
302 (funcall (cdr (assoc 'verification-func (funcall scheme)))
303 (car limits) (cdr limits))))))
304
305
306 ;;}}}
307 ;;{{{ Key management
308
309 ;;{{{ mc-insert-public-key
310
311 ;;;###autoload
312 (defun mc-insert-public-key (&optional userid scheme)
313 "*Insert your public key at point.
314 With one prefix arg, prompts for user id to use. With two prefix
315 args, prompts for encryption scheme."
316 (interactive
317 (let (arglist)
318 (if (not (and (listp current-prefix-arg)
319 (numberp (car current-prefix-arg))))
320 nil
321 (if (>= (car current-prefix-arg) 16)
322 (setq arglist
323 (cons (cdr (assoc (completing-read "Encryption Scheme: "
324 mc-schemes)
325 mc-schemes))
326 arglist)))
327 (if (>= (car current-prefix-arg) 4)
328 (setq arglist (cons (read-string "User ID: ") arglist))))
329 arglist))
330
331 ; (if (< (point) (mc-find-headers-end))
332 ; (error "Can't insert key inside message header"))
333 (or scheme (setq scheme mc-default-scheme))
334 (or userid (setq userid (cdr (assoc 'user-id (funcall scheme)))))
335
336 ;; (goto-char (point-max))
337 (if (not (bolp))
338 (insert "\n"))
339 (funcall (cdr (assoc 'key-insertion-func (funcall scheme))) userid))
340
341 ;;}}}
342 ;;{{{ mc-snarf-keys
343
344 ;;;###autoload
345 (defun mc-snarf ()
346 "*Add all public keys in the buffer to your keyring.
347
348 Exact behavior depends on current major mode."
349 (interactive)
350 (let* ((mode-alist (cdr-safe (assq major-mode mc-modes-alist)))
351 (func (or (cdr-safe (assq 'snarf mode-alist))
352 'mc-snarf-keys)))
353 (funcall func)))
354
355 ;;;###autoload
356 (defun mc-snarf-keys ()
357 "*Add all public keys in the buffer to your keyring."
358 (interactive)
359 (let ((schemes mc-schemes)
360 (start (point-min))
361 (found 0)
362 limits scheme)
363 (save-excursion
364 (catch 'done
365 (while t
366 (while (and schemes
367 (setq scheme (cdr (car schemes)))
368 (not
369 (setq
370 limits
371 (mc-message-delimiter-positions
372 (cdr (assoc 'key-begin-line (funcall scheme)))
373 (cdr (assoc 'key-end-line (funcall scheme)))
374 start))))
375 (setq schemes (cdr schemes)))
376 (if (null limits)
377 (throw 'done found)
378 (setq start (cdr limits))
379 (setq found (+ found (funcall (cdr (assoc 'snarf-func
380 (funcall scheme)))
381 (car limits) (cdr limits)))))))
382 (message (format "%d new key%s found" found
383 (if (eq 1 found) "" "s"))))))
384 ;;}}}
385 ;;}}}
386 ;;{{{ Mode specific functions
387
388 ;;{{{ RMAIL
389 ;;;###autoload
390 (defun mc-rmail-summary-verify-signature ()
391 "*Verify the signature in the current message."
392 (interactive)
393 (if (not (eq major-mode 'rmail-summary-mode))
394 (error
395 "mc-rmail-summary-verify-signature called in inappropriate buffer"))
396 (save-excursion
397 (set-buffer rmail-buffer)
398 (mc-verify)))
399
400 ;;;###autoload
401 (defun mc-rmail-summary-decrypt-message ()
402 "*Decrypt the contents of this message"
403 (interactive)
404 (if (not (eq major-mode 'rmail-summary-mode))
405 (error
406 "mc-rmail-summary-decrypt-message called in inappropriate buffer"))
407 (save-excursion
408 (set-buffer rmail-buffer)
409 (mc-decrypt)))
410
411 ;;;###autoload
412 (defun mc-rmail-summary-snarf-keys ()
413 "*Adds keys from current message to public key ring"
414 (interactive)
415 (if (not (eq major-mode 'rmail-summary-mode))
416 (error
417 "mc-rmail-summary-snarf-keys called in inappropriate buffer"))
418 (save-excursion
419 (set-buffer rmail-buffer)
420 (mc-snarf)))
421
422 ;;;###autoload
423 (defun mc-rmail-verify-signature ()
424 "*Verify the signature in the current message."
425 (interactive)
426 (if (not (equal mode-name "RMAIL"))
427 (error "mc-rmail-verify-signature called in a non-RMAIL buffer"))
428 ;; Hack to load rmailkwd before verifying sig
429 (rmail-add-label "verified")
430 (rmail-kill-label "verified")
431 (if (mc-verify-signature)
432 (rmail-add-label "verified")))
433
434 ;;;###autoload
435 (defun mc-rmail-decrypt-message ()
436 "*Decrypt the contents of this message"
437 (interactive)
438 (let (decryption-result)
439 (if (not (equal mode-name "RMAIL"))
440 (error "mc-rmail-decrypt-message called in a non-RMAIL buffer"))
441 (unwind-protect
442 (progn
443 (rmail-edit-current-message)
444 (setq decryption-result (mc-decrypt-message))
445 (cond ((not (car decryption-result))
446 (rmail-abort-edit))
447 ((and (not (eq mc-always-replace 'never))
448 (or mc-always-replace
449 (y-or-n-p
450 "Replace encrypted message with decrypted? ")))
451 (rmail-cease-edit)
452 (rmail-kill-label "edited")
453 (rmail-add-label "decrypted")
454 (if (cdr decryption-result)
455 (rmail-add-label "verified")))
456 (t
457 (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*")))
458 (copy-to-buffer tmp (point-min) (point-max))
459 (rmail-abort-edit)
460 (switch-to-buffer tmp t)
461 (goto-char (point-min))
462 (insert "From Mailcrypt-" mc-version " "
463 (current-time-string) "\n")
464 (rmail-convert-file)
465 (rmail-mode)
466 (use-local-map (copy-keymap (current-local-map)))
467 (local-set-key "q" 'mc-rmail-view-quit)
468 (set-buffer-modified-p nil)))))
469 (if (eq major-mode 'rmail-edit-mode)
470 (rmail-abort-edit)))))
471
472 (defun mc-rmail-view-quit ()
473 (interactive)
474 (let ((buf (current-buffer)))
475 (set-buffer-modified-p nil)
476 (rmail-quit)
477 (kill-buffer buf)))
478
479 ;;}}}
480 ;;{{{ VM
481 ;;;###autoload
482 (defun mc-vm-verify-signature ()
483 "*Verify the signature in the current VM message"
484 (interactive)
485 (if (interactive-p)
486 (vm-follow-summary-cursor))
487 (vm-select-folder-buffer)
488 (vm-check-for-killed-summary)
489 (vm-error-if-folder-empty)
490 (save-restriction
491 (vm-widen-page)
492 (mc-verify-signature)))
493
494 ;;;###autoload
495 (defun mc-vm-decrypt-message ()
496 "*Decrypt the contents of the current VM message"
497 (interactive)
498 (let ((vm-frame-per-edit nil)
499 from-line)
500 (if (interactive-p)
501 (vm-follow-summary-cursor))
502 (vm-select-folder-buffer)
503 (vm-check-for-killed-summary)
504 (vm-error-if-folder-read-only)
505 (vm-error-if-folder-empty)
506
507 ;; store away a valid "From " line for possible later use.
508 (setq from-line (vm-leading-message-separator))
509 (vm-edit-message)
510 (cond ((not (condition-case condition-data
511 (car (mc-decrypt-message))
512 (error
513 (vm-edit-message-abort)
514 (error (message "Decryption failed: %s"
515 (car (cdr condition-data)))))))
516 (vm-edit-message-abort)
517 (error "Decryption failed."))
518 ((and (not (eq mc-always-replace 'never))
519 (or mc-always-replace
520 (y-or-n-p "Replace encrypted message with decrypted? ")))
521 (let ((this-command 'vm-edit-message-end))
522 (vm-edit-message-end)))
523 (t
524 (let ((tmp (generate-new-buffer "*Mailcrypt Viewing*")))
525 (copy-to-buffer tmp (point-min) (point-max))
526 (vm-edit-message-abort)
527 (switch-to-buffer tmp t)
528 (goto-char (point-min))
529 (insert from-line)
530 (set-buffer-modified-p nil)
531 (vm-mode t))))))
532
533 ;;;###autoload
534 (defun mc-vm-snarf-keys ()
535 "*Snarf public key from the contents of the current VM message"
536 (interactive)
537 (if (interactive-p)
538 (vm-follow-summary-cursor))
539 (vm-select-folder-buffer)
540 (vm-check-for-killed-summary)
541 (vm-error-if-folder-empty)
542 (save-restriction
543 (vm-widen-page)
544 (mc-snarf-keys)))
545
546 ;;}}}
547 ;;{{{ GNUS
548
549 ;;;###autoload
550 (defun mc-gnus-verify-signature ()
551 (interactive)
552 (gnus-summary-select-article)
553 (gnus-eval-in-buffer-window gnus-article-buffer
554 (save-restriction (widen) (mc-verify-signature))))
555
556 ;;;###autoload
557 (defun mc-gnus-snarf-keys ()
558 (interactive)
559 (gnus-summary-select-article)
560 (gnus-eval-in-buffer-window gnus-article-buffer
561 (save-restriction (widen) (mc-snarf-keys))))
562
563 ;;;###autoload
564 (defun mc-gnus-decrypt-message ()
565 (interactive)
566 (gnus-summary-select-article)
567 ;; Gnus 5 has the string "Gnus" instead of "GNUS" in gnus-version.
568 (if (not (let ((case-fold-search nil))
569 (string-match "Gnus" gnus-version)))
570 (gnus-eval-in-buffer-window
571 gnus-article-buffer
572 (save-restriction (widen) (mc-decrypt-message)))
573 ;; Gnus 5 allows editing of articles. (Actually, it makes a great
574 ;; mail reader.)
575 (gnus-eval-in-buffer-window gnus-article-buffer
576 (gnus-summary-edit-article t)
577 (save-restriction
578 (widen)
579 (cond ((not (car (mc-decrypt-message)))
580 (gnus-summary-edit-article-postpone))
581 ((and (not (gnus-group-read-only-p))
582 (not (eq mc-always-replace 'never))
583 (or mc-always-replace
584 (y-or-n-p
585 "Replace encrypted message on disk? ")))
586 (gnus-summary-edit-article-done))
587 (t
588 (gnus-summary-edit-article-postpone)))))))
589
590 ;;}}}
591 ;;{{{ MH
592
593 ;;;###autoload
594 (defun mc-mh-decrypt-message ()
595 "Decrypt the contents of the current MH message in the show buffer."
596 (interactive "P")
597 (let* ((msg (mh-get-msg-num t))
598 (msg-filename (mh-msg-filename msg))
599 (show-buffer (get-buffer mh-show-buffer))
600 decrypt-okay decrypt-on-disk)
601 (setq
602 decrypt-on-disk
603 (and (not (eq mc-always-replace 'never))
604 (or mc-always-replace
605 (y-or-n-p "Replace encrypted message on disk? "))))
606 (if decrypt-on-disk
607 (progn
608 (save-excursion
609 (set-buffer (create-file-buffer msg-filename))
610 (insert-file-contents msg-filename t)
611 (if (setq decrypt-okay (car (mc-decrypt-message)))
612 (save-buffer)
613 (message "Decryption failed.")
614 (set-buffer-modified-p nil))
615 (kill-buffer nil))
616 (if decrypt-okay
617 (if (and show-buffer
618 (equal msg-filename (buffer-file-name show-buffer)))
619 (save-excursion
620 (save-window-excursion
621 (mh-invalidate-show-buffer)))))
622 (mh-show msg))
623 (mh-show msg)
624 (save-excursion
625 (set-buffer mh-show-buffer)
626 (if (setq decrypt-okay (car (mc-decrypt-message)))
627 (progn
628 (goto-char (point-min))
629 (set-buffer-modified-p nil))
630 (message "Decryption failed.")))
631 (if (not decrypt-okay)
632 (progn
633 (mh-invalidate-show-buffer)
634 (mh-show msg))))))
635
636 ;;;###autoload
637 (defun mc-mh-verify-signature ()
638 "*Verify the signature in the current MH message."
639 (interactive)
640 (mh-show)
641 (mh-in-show-buffer (mh-show-buffer)
642 (mc-verify-signature)))
643
644
645 ;;;###autoload
646 (defun mc-mh-snarf-keys ()
647 (interactive)
648 (mh-show)
649 (mh-in-show-buffer (mh-show-buffer)
650 (mc-snarf-keys)))
651
652 ;;}}}
653
654 ;;}}}