1
;; mailcrypt.el v3.5.6, mail encryption with PGP
2
;; Copyright (C) 1995 Jin Choi <jin@atype.com>
3
;; Patrick LoPresti <patl@lcs.mit.edu>
4
;; (C) 1998 Len Budney <lbudney@pobox.com>
5
;; (C) 2001 Brian Warner <warner@lothar.com>
6
;; Any comments or suggestions welcome.
7
;; Inspired by pgp.el, by Gray Watson <gray@antaire.com>.
10
;; This file is intended to be used with GNU Emacs.
12
;; This program 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)
17
;; This program 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.
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
24
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
27
;;{{{ Load some required packages
31
(autoload 'start-itimer "itimer")
32
(autoload 'cancel-itimer "itimer")
33
(autoload 'delete-itimer "itimer"))
40
(condition-case nil (require 'itimer) (error nil))
41
(if (not (featurep 'itimer))
42
(condition-case nil (require 'timer) (error nil)))
44
(if (not (fboundp 'buffer-substring-no-properties))
45
(fset 'buffer-substring-no-properties 'buffer-substring)))
47
(defconst mc-xemacs-p (string-match "XEmacs" emacs-version))
49
(autoload 'mc-decrypt "mc-toplev" nil t)
50
(autoload 'mc-verify "mc-toplev" nil t)
51
(autoload 'mc-snarf "mc-toplev" nil t)
52
(autoload 'mc-pgp-fetch-key "mc-pgp" nil t)
53
(autoload 'mc-encrypt "mc-toplev" nil t)
54
(autoload 'mc-sign "mc-toplev" nil t)
55
(autoload 'mc-insert-public-key "mc-toplev" nil t)
56
(autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t)
57
(autoload 'mc-remailer-insert-response-block "mc-remail" nil t)
58
(autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t)
59
(autoload 'mc-setversion "mc-setversion" nil t)
63
;;{{{ Minor mode variables and functions
65
(defvar mc-pgp-always-sign nil
66
"*If t, always sign encrypted PGP messages, or never sign if 'never.")
68
(defvar mc-read-mode nil
69
"Non-nil means Mailcrypt read mode key bindings are available.")
71
(defvar mc-write-mode nil
72
"Non-nil means Mailcrypt write mode key bindings are available.")
74
(make-variable-buffer-local 'mc-read-mode)
75
(make-variable-buffer-local 'mc-write-mode)
77
(defvar mc-read-mode-string " MC-r"
78
"*String to put in mode line when Mailcrypt read mode is active.")
80
(defvar mc-write-mode-string " MC-w"
81
"*String to put in mode line when Mailcrypt write mode is active.")
83
(defvar mc-read-mode-map nil
84
"Keymap for Mailcrypt read mode bindings.")
86
(defvar mc-write-mode-map nil
87
"Keymap for Mailcrypt write mode bindings.")
91
(setq mc-read-mode-map (make-sparse-keymap))
92
(define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd)
93
(define-key mc-read-mode-map "\C-c/d" 'mc-decrypt)
94
(define-key mc-read-mode-map "\C-c/v" 'mc-verify)
95
(define-key mc-read-mode-map "\C-c/a" 'mc-snarf)
96
(define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key)))
100
(setq mc-write-mode-map (make-sparse-keymap))
101
(define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd)
102
(define-key mc-write-mode-map "\C-c/e" 'mc-encrypt)
103
(define-key mc-write-mode-map "\C-c/s" 'mc-sign)
104
(define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key)
105
(define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key)
106
(define-key mc-write-mode-map "\C-c/r"
107
'mc-remailer-encrypt-for-chain)
108
(define-key mc-write-mode-map "\C-c/b"
109
'mc-remailer-insert-response-block)
110
(define-key mc-write-mode-map "\C-c/p"
111
'mc-remailer-insert-pseudonym)))
114
mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map))
115
"Mailcrypt read mode menu."
117
["Decrypt Message" mc-decrypt t]
118
["Verify Signature" mc-verify t]
119
["Snarf Keys" mc-snarf t]
120
["Fetch Key" mc-pgp-fetch-key t]
121
["Forget Passphrase(s)" mc-deactivate-passwd t]))
124
mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map))
125
"Mailcrypt write mode menu."
127
["Encrypt Message" mc-encrypt t]
128
["Sign Message" mc-sign t]
129
["Insert Public Key" mc-insert-public-key t]
130
["Fetch Key" mc-pgp-fetch-key t]
131
["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t]
132
["Insert Pseudonym" mc-remailer-insert-pseudonym t]
133
["Insert Response Block" mc-remailer-insert-response-block t]
134
["Forget Passphrase(s)" mc-deactivate-passwd t]))
136
(or (assq 'mc-read-mode minor-mode-map-alist)
137
(setq minor-mode-map-alist
138
(cons (cons 'mc-read-mode mc-read-mode-map)
139
minor-mode-map-alist)))
141
(or (assq 'mc-write-mode minor-mode-map-alist)
142
(setq minor-mode-map-alist
143
(cons (cons 'mc-write-mode mc-write-mode-map)
144
minor-mode-map-alist)))
146
(or (assq 'mc-read-mode minor-mode-alist)
147
(setq minor-mode-alist
148
(cons '(mc-read-mode mc-read-mode-string) minor-mode-alist)))
150
(or (assq 'mc-write-mode minor-mode-alist)
151
(setq minor-mode-alist
152
(cons '(mc-write-mode mc-write-mode-string) minor-mode-alist)))
154
(defun mc-read-mode (&optional arg)
155
"\nMinor mode for interfacing with cryptographic functions.
157
\\[mc-decrypt]\t\tDecrypt an encrypted message
158
\\[mc-verify]\t\tVerify signature on a clearsigned message
159
\\[mc-snarf]\t\tAdd public key(s) to keyring
160
\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
161
\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
164
(if (null arg) (not mc-read-mode)
165
(> (prefix-numeric-value arg) 0)))
166
(and mc-read-mode mc-write-mode (mc-write-mode nil))
168
(easy-menu-add mc-read-mode-menu)
169
(easy-menu-remove mc-read-mode-menu)))
171
(defun mc-write-mode (&optional arg)
172
"\nMinor mode for interfacing with cryptographic functions.
173
\\<mc-write-mode-map>
174
\\[mc-encrypt]\t\tEncrypt (and optionally sign) message
175
\\[mc-sign]\t\tClearsign message
176
\\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message
177
\\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
178
\\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing
179
\\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing)
180
\\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing)
181
\\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
184
(if (null arg) (not mc-write-mode)
185
(> (prefix-numeric-value arg) 0)))
186
(and mc-write-mode mc-read-mode (mc-read-mode nil))
188
(easy-menu-add mc-write-mode-menu)
189
(easy-menu-remove mc-write-mode-menu)))
191
(defun mc-install-read-mode ()
195
(defun mc-install-write-mode ()
202
;; The funny triple braces you see are used by `folding-mode', a minor
203
;; mode by Jamie Lokier, available from the elisp archive.
206
;;{{{ User variables.
207
(defconst mc-version "3.5.8")
208
(defvar mc-temp-directory
209
(cond ((fboundp 'temp-directory) (temp-directory))
210
((boundp 'temporary-file-directory) temporary-file-directory)
212
"*Default temp directory to be used by Mailcrypt.")
213
(defvar mc-default-scheme 'mc-scheme-pgp "*Default encryption scheme to use.")
214
(defvar mc-passwd-timeout 60
215
"*Time to deactivate password in seconds after a use.
216
nil or 0 means deactivate immediately. If the only timer package available
217
is the 'timer' package, then this can be a string in timer format.")
219
(defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME")
220
(user-full-name) "*Your RIPEM user ID."))
222
(defvar mc-always-replace nil
223
"*If t, decrypt mail messages in place without prompting.
225
If 'never, always use a viewer instead of replacing.")
227
(defvar mc-use-default-recipients nil "*Assume that the message should
228
be encoded for everyone listed in the To, Cc, and Bcc fields.")
230
(defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with
233
(defvar mc-pre-signature-hook nil
234
"*List of hook functions to run immediately before signing.")
235
(defvar mc-post-signature-hook nil
236
"*List of hook functions to run immediately after signing.")
237
(defvar mc-pre-encryption-hook nil
238
"*List of hook functions to run immediately before encrypting.")
239
(defvar mc-post-encryption-hook nil
240
"*List of hook functions to run after encrypting.")
241
(defvar mc-pre-decryption-hook nil
242
"*List of hook functions to run immediately before decrypting.")
243
(defvar mc-post-decryption-hook nil
244
"*List of hook functions to run after decrypting.")
246
(defconst mc-buffer-name "*MailCrypt*"
247
"Name of temporary buffer for mailcrypt")
249
(defvar mc-modes-alist
250
'((rmail-mode (decrypt . mc-rmail-decrypt-message)
251
(verify . mc-rmail-verify-signature))
252
(rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message)
253
(verify . mc-rmail-summary-verify-signature)
254
(snarf . mc-rmail-summary-snarf-keys))
255
(mew-draft-mode (encrypt . mc-encrypt-message)
256
(sign . mc-sign-message))
257
(mew-message-mode (decrypt . mc-mew-decrypt-message))
258
(mew-summary-mode (decrypt . mc-mew-summary-decrypt-message)
259
(verify . mc-mew-summary-verify-signature)
260
(snarf . mc-mew-summary-snarf-keys))
261
(vm-mode (decrypt . mc-vm-decrypt-message)
262
(verify . mc-vm-verify-signature)
263
(snarf . mc-vm-snarf-keys))
264
(vm-virtual-mode (decrypt . mc-vm-decrypt-message)
265
(verify . mc-vm-verify-signature)
266
(snarf . mc-vm-snarf-keys))
267
(vm-summary-mode (decrypt . mc-vm-decrypt-message)
268
(verify . mc-vm-verify-signature)
269
(snarf . mc-vm-snarf-keys))
270
(mh-folder-mode (decrypt . mc-mh-decrypt-message)
271
(verify . mc-mh-verify-signature)
272
(snarf . mc-mh-snarf-keys))
273
(message-mode (encrypt . mc-encrypt-message)
274
(sign . mc-sign-message))
275
(gnus-summary-mode (decrypt . mc-gnus-decrypt-message)
276
(verify . mc-gnus-verify-signature)
277
(snarf . mc-gnus-snarf-keys))
278
(gnus-article-mode (decrypt . mc-gnus-decrypt-message)
279
(verify . mc-gnus-verify-signature)
280
(snarf . mc-gnus-snarf-keys))
281
(mail-mode (encrypt . mc-encrypt-message)
282
(sign . mc-sign-message))
283
(vm-mail-mode (encrypt . mc-encrypt-message)
284
(sign . mc-sign-message))
285
(mh-letter-mode (encrypt . mc-encrypt-message)
286
(sign . mc-sign-message))
287
(news-reply-mode (encrypt . mc-encrypt-message)
288
(sign . mc-sign-message)))
290
"Association list (indexed by major mode) of association lists
291
(indexed by operation) of functions to call for each major mode.")
294
;;{{{ Program variables and constants.
296
(defvar mc-timer nil "Timer object for password deactivation.")
298
(defvar mc-passwd-cache nil "Cache for passphrases.")
300
(defvar mc-schemes '(("pgp50" . mc-scheme-pgp50)
301
("pgp" . mc-scheme-pgp)
302
("gpg" . mc-scheme-gpg)
307
;;{{{ Utility functions.
309
(defun mc-message-delimiter-positions (start-re end-re &optional begin)
310
;; Returns pair of integers (START . END) that delimit message marked off
311
;; by the regular expressions start-re and end-re. Optional argument BEGIN
312
;; determines where we should start looking from.
313
(setq begin (or begin (point-min)))
317
(and (re-search-forward start-re nil t)
318
(setq start (match-beginning 0))
319
(re-search-forward end-re nil t)
320
(cons start (point))))))
323
(defun mc-split (regexp str)
324
"Splits STR into a list of elements which were separated by REGEXP,
325
stripping initial and trailing whitespace."
326
(let ((data (match-data))
331
(string-match "[ \t\n]*" str) ; Will always match at 0
332
(setq beg (match-end 0))
333
(setq end (string-match "[ \t\n]*\\'" str))
334
(while (string-match regexp str beg)
336
(cons (substring str beg (match-beginning 0))
338
(setq beg (match-end 0)))
339
(if (not (= (length str) beg)) ; Not end
340
(setq retval (cons (substring str beg end) retval)))
342
(store-match-data data))))
344
;;; FIXME - Function never called?
345
;(defun mc-temp-display (beg end &optional name)
348
; (setq name mc-buffer-name))
349
; (if (string-match name "*ERROR*")
351
; (message "mailcrypt: An error occured! See *ERROR* buffer.")
353
; (setq tmp (buffer-substring beg end))
354
; (delete-region beg end)
356
; (save-window-excursion
357
; (with-output-to-temp-buffer name
360
;; In case I ever decide to do this right.
361
;; LRB - Thanks Pat! This helped a lot in updating mixmaster support.
362
;; mc-field-name-regexp now catches precisely those email headers
363
;; which are RFC-822 compliant.
364
(defconst mc-field-name-regexp
367
(char-to-string 33) "-" (char-to-string 57)
368
(char-to-string 59) "-" (char-to-string 126)
370
(defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)")
372
(defun mc-get-fields (&optional matching bounds nuke)
373
"Get all header fields within BOUNDS. Return as an
374
alist ((FIELD-NAME . FIELD-BODY) (FIELD-NAME . FIELD-BODY) ...).
376
Argument MATCHING, if present, is a regexp which each FIELD-NAME
377
must match exactly. Matching is case-insensitive.
379
Optional arg NUKE, if non-nil, means eliminate all fields returned."
382
(let ((case-fold-search t)
384
(concat mc-field-name-regexp ":" mc-field-body-regexp))
385
ret name body field-start field-end)
386
;; Ensure exact match
388
(setq matching (concat "^\\(" matching "\\)$")))
391
(narrow-to-region (car bounds) (cdr bounds)))
393
(goto-char (point-max))
395
(while (re-search-backward header-field-regexp nil 'move)
396
(setq field-start (match-beginning 0))
397
(setq field-end (match-end 0))
398
(setq name (buffer-substring-no-properties
399
(match-beginning 1) (match-end 1)))
400
(setq body (buffer-substring-no-properties
401
(match-beginning 2) (match-end 2)))
402
(if (or (null matching) (string-match matching name))
404
(setq ret (cons (cons name body) ret))
406
(delete-region field-start field-end)))))
409
(defsubst mc-strip-address (addr)
410
"Strip everything from ADDR except the basic Email address."
411
(car (rfc822-addresses addr)))
413
(defun mc-strip-addresses (addr-list)
414
"Strip everything from the addresses in ADDR-LIST except the basic
415
Email address. ADDR-LIST may be a single string or a list of strings."
416
(if (not (listp addr-list)) (setq addr-list (list addr-list)))
419
(function (lambda (s) (rfc822-addresses s)))
421
(setq addr-list (apply 'append addr-list))
422
(mapconcat 'mc-strip-address addr-list ", "))
424
(defun mc-display-buffer (buffer)
425
"Like display-buffer, but always display top of the buffer."
428
(goto-char (point-min))
429
(display-buffer buffer)))
431
(defun mc-message (msg &optional buffer default)
432
;; returns t if we used msg, nil if we used default
438
(goto-char (point-min))
439
(if (re-search-forward msg nil t)
440
(buffer-substring-no-properties
441
(match-beginning 0) (match-end 0))
444
(if msg (message-or-box "%s" msg))
447
(defun mc-message-sigstatus (msg &optional attention)
448
"Emit a signature status line. If ATTENTION is non-nil, be noisy about it."
449
;; this function exists to be overridden by the unit tests
450
(if attention (ding))
451
(message-or-box "%s" msg)
454
(defun mc-process-region (beg end passwd program args parser &optional buffer)
455
(let ((obuf (current-buffer))
456
(process-connection-type nil)
457
mybuf result rgn proc)
460
(setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
464
(buffer-disable-undo mybuf)
466
(apply 'start-process "*PGP*" mybuf program args))
469
(process-send-string proc (concat passwd "\n"))
470
(or mc-passwd-timeout (mc-deactivate-passwd t))))
471
(process-send-region proc beg end)
472
(process-send-eof proc)
473
(while (eq 'run (process-status proc))
474
(accept-process-output proc 5))
475
(setq result (process-exit-status proc))
476
;; Hack to force a status_notify() in Emacs 19.29
477
(delete-process proc)
479
(goto-char (point-max))
480
(if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
481
(delete-region (match-beginning 0) (match-end 0)))
482
(goto-char (point-min))
484
(while (search-forward "\r\n" nil t)
485
(replace-match "\n"))
486
;; Hurm. FIXME; must get better result codes.
488
(error "%s exited abnormally: '%s'" program result)
489
(setq rgn (funcall parser result))
490
;; If the parser found something, migrate it
494
(delete-region beg end)
496
(insert-buffer-substring mybuf (car rgn) (cdr rgn))
498
(delete-region (car rgn) (cdr rgn)))))
499
;; Return nil on failure and exit code on success
501
;; Cleanup even on nonlocal exit
502
(if (and proc (eq 'run (process-status proc)))
503
(interrupt-process proc))
505
(or buffer (null mybuf) (kill-buffer mybuf)))))
509
;;{{{ Passphrase management
510
(defun mc-activate-passwd (id &optional prompt)
511
"Activate the passphrase matching ID, using PROMPT for a prompt.
512
Return the passphrase. If PROMPT is nil, only return value if cached."
513
(cond ((featurep 'itimer)
514
(if mc-timer (delete-itimer mc-timer))
515
(setq mc-timer (if mc-passwd-timeout
516
(start-itimer "mc-itimer"
517
'mc-deactivate-passwd
521
(let ((string-time (if (integerp mc-passwd-timeout)
522
(format "%d sec" mc-passwd-timeout)
524
(if mc-timer (cancel-timer mc-timer))
525
(setq mc-timer (if string-time
526
(run-at-time string-time
527
nil 'mc-deactivate-passwd)
529
(let ((cell (assoc id mc-passwd-cache))
531
(setq passwd (cdr-safe cell))
532
(if (and (not passwd) prompt)
533
(setq passwd (comint-read-noecho prompt)))
536
(setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache)))
539
(defun mc-deactivate-passwd (&optional inhibit-message)
540
"*Deactivate the passphrase cache."
543
(cond ((featurep 'itimer) (delete-itimer mc-timer))
544
((featurep 'timer) (cancel-timer mc-timer))))
548
(if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0))
552
(not (interactive-p))
553
(message "Passphrase%s deactivated"
554
(if (> (length mc-passwd-cache) 1) "s" ""))))
558
;;{{{ Define several aliases so that an apropos on `mailcrypt' will
560
(defalias 'mailcrypt-encrypt 'mc-encrypt)
561
(defalias 'mailcrypt-decrypt 'mc-decrypt)
562
(defalias 'mailcrypt-sign 'mc-sign)
563
(defalias 'mailcrypt-verify 'mc-verify)
564
(defalias 'mailcrypt-insert-public-key 'mc-insert-public-key)
565
(defalias 'mailcrypt-snarf 'mc-snarf)