|
0
|
1 ;; mailcrypt.el v3.4, mail encryption with PGP
|
|
|
2 ;; Copyright (C) 1995 Jin Choi <jin@atype.com>
|
|
|
3 ;; Patrick LoPresti <patl@lcs.mit.edu>
|
|
|
4 ;; Any comments or suggestions welcome.
|
|
|
5 ;; Inspired by pgp.el, by Gray Watson <gray@antaire.com>.
|
|
|
6
|
|
|
7 ;;{{{ Licensing
|
|
|
8 ;; This file is intended to be used with GNU Emacs.
|
|
|
9
|
|
|
10 ;; This program is free software; you can redistribute it and/or modify
|
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; This program is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
|
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
23 ;;}}}
|
|
|
24
|
|
|
25 ;;{{{ Load some required packages
|
|
|
26
|
|
|
27 (eval-when-compile
|
|
|
28 ;; Quiet warnings
|
|
|
29 (autoload 'start-itimer "itimer")
|
|
|
30 (autoload 'cancel-itimer "itimer")
|
|
|
31 (autoload 'delete-itimer "itimer"))
|
|
|
32
|
|
|
33 (require 'easymenu)
|
|
|
34 (require 'comint)
|
|
|
35
|
|
|
36 (eval-and-compile
|
|
|
37 (condition-case nil (require 'itimer) (error nil))
|
|
|
38 (if (not (featurep 'itimer))
|
|
|
39 (condition-case nil (require 'timer) (error nil)))
|
|
|
40
|
|
|
41 (if (not (fboundp 'buffer-substring-no-properties))
|
|
|
42 (fset 'buffer-substring-no-properties 'buffer-substring)))
|
|
|
43
|
|
|
44 (defconst mc-xemacs-p (string-match "XEmacs" emacs-version))
|
|
|
45
|
|
|
46 (if (not mc-xemacs-p)
|
|
|
47 (progn
|
|
|
48 (autoload 'mc-decrypt "mc-toplev" nil t)
|
|
|
49 (autoload 'mc-verify "mc-toplev" nil t)
|
|
|
50 (autoload 'mc-snarf "mc-toplev" nil t)
|
|
|
51 (autoload 'mc-pgp-fetch-key "mc-pgp" nil t)
|
|
|
52 (autoload 'mc-encrypt "mc-toplev" nil t)
|
|
|
53 (autoload 'mc-sign "mc-toplev" nil t)
|
|
|
54 (autoload 'mc-insert-public-key "mc-toplev" nil t)
|
|
|
55 (autoload 'mc-remailer-encrypt-for-chain "mc-remail" nil t)
|
|
|
56 (autoload 'mc-remailer-insert-response-block "mc-remail" nil t)
|
|
|
57 (autoload 'mc-remailer-insert-pseudonym "mc-remail" nil t)))
|
|
|
58
|
|
|
59 ;;}}}
|
|
|
60
|
|
|
61 ;;{{{ Minor mode variables and functions
|
|
|
62
|
|
|
63 (defvar mc-read-mode nil
|
|
|
64 "Non-nil means Mailcrypt read mode key bindings are available.")
|
|
|
65
|
|
|
66 (defvar mc-write-mode nil
|
|
|
67 "Non-nil means Mailcrypt write mode key bindings are available.")
|
|
|
68
|
|
|
69 (make-variable-buffer-local 'mc-read-mode)
|
|
|
70 (make-variable-buffer-local 'mc-write-mode)
|
|
|
71
|
|
|
72 (defvar mc-read-mode-string " MC-r"
|
|
|
73 "*String to put in mode line when Mailcrypt read mode is active.")
|
|
|
74
|
|
|
75 (defvar mc-write-mode-string " MC-w"
|
|
|
76 "*String to put in mode line when Mailcrypt write mode is active.")
|
|
|
77
|
|
|
78 (defvar mc-read-mode-map nil
|
|
|
79 "Keymap for Mailcrypt read mode bindings.")
|
|
|
80
|
|
|
81 (defvar mc-write-mode-map nil
|
|
|
82 "Keymap for Mailcrypt write mode bindings.")
|
|
|
83
|
|
|
84 (or mc-read-mode-map
|
|
|
85 (progn
|
|
|
86 (setq mc-read-mode-map (make-sparse-keymap))
|
|
|
87 (define-key mc-read-mode-map "\C-c/f" 'mc-deactivate-passwd)
|
|
|
88 (define-key mc-read-mode-map "\C-c/d" 'mc-decrypt)
|
|
|
89 (define-key mc-read-mode-map "\C-c/v" 'mc-verify)
|
|
|
90 (define-key mc-read-mode-map "\C-c/a" 'mc-snarf)
|
|
|
91 (define-key mc-read-mode-map "\C-c/k" 'mc-pgp-fetch-key)))
|
|
|
92
|
|
|
93 (or mc-write-mode-map
|
|
|
94 (progn
|
|
|
95 (setq mc-write-mode-map (make-sparse-keymap))
|
|
|
96 (define-key mc-write-mode-map "\C-c/f" 'mc-deactivate-passwd)
|
|
|
97 (define-key mc-write-mode-map "\C-c/e" 'mc-encrypt)
|
|
|
98 (define-key mc-write-mode-map "\C-c/s" 'mc-sign)
|
|
|
99 (define-key mc-write-mode-map "\C-c/x" 'mc-insert-public-key)
|
|
|
100 (define-key mc-write-mode-map "\C-c/k" 'mc-pgp-fetch-key)
|
|
|
101 (define-key mc-write-mode-map "\C-c/r"
|
|
|
102 'mc-remailer-encrypt-for-chain)
|
|
|
103 (define-key mc-write-mode-map "\C-c/b"
|
|
|
104 'mc-remailer-insert-response-block)
|
|
|
105 (define-key mc-write-mode-map "\C-c/p"
|
|
|
106 'mc-remailer-insert-pseudonym)))
|
|
|
107
|
|
|
108 (easy-menu-define
|
|
|
109 mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map))
|
|
|
110 "Mailcrypt read mode menu."
|
|
|
111 '("Mailcrypt"
|
|
|
112 ["Decrypt Message" mc-decrypt t]
|
|
|
113 ["Verify Signature" mc-verify t]
|
|
|
114 ["Snarf Keys" mc-snarf t]
|
|
|
115 ["Fetch Key" mc-pgp-fetch-key t]
|
|
|
116 ["Forget Passphrase(s)" mc-deactivate-passwd t]))
|
|
|
117
|
|
|
118 (easy-menu-define
|
|
|
119 mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map))
|
|
|
120 "Mailcrypt write mode menu."
|
|
|
121 '("Mailcrypt"
|
|
|
122 ["Encrypt Message" mc-encrypt t]
|
|
|
123 ["Sign Message" mc-sign t]
|
|
|
124 ["Insert Public Key" mc-insert-public-key t]
|
|
|
125 ["Fetch Key" mc-pgp-fetch-key t]
|
|
|
126 ["Encrypt for Remailer(s)" mc-remailer-encrypt-for-chain t]
|
|
|
127 ["Insert Pseudonym" mc-remailer-insert-pseudonym t]
|
|
|
128 ["Insert Response Block" mc-remailer-insert-response-block t]
|
|
|
129 ["Forget Passphrase(s)" mc-deactivate-passwd t]))
|
|
|
130
|
|
|
131 (or (assq 'mc-read-mode minor-mode-map-alist)
|
|
|
132 (setq minor-mode-map-alist
|
|
|
133 (cons (cons 'mc-read-mode mc-read-mode-map)
|
|
|
134 minor-mode-map-alist)))
|
|
|
135
|
|
|
136 (or (assq 'mc-write-mode minor-mode-map-alist)
|
|
|
137 (setq minor-mode-map-alist
|
|
|
138 (cons (cons 'mc-write-mode mc-write-mode-map)
|
|
|
139 minor-mode-map-alist)))
|
|
|
140
|
|
|
141 (or (assq 'mc-read-mode minor-mode-alist)
|
|
|
142 (setq minor-mode-alist
|
|
|
143 (cons '(mc-read-mode mc-read-mode-string) minor-mode-alist)))
|
|
|
144
|
|
|
145 (or (assq 'mc-write-mode minor-mode-alist)
|
|
|
146 (setq minor-mode-alist
|
|
|
147 (cons '(mc-write-mode mc-write-mode-string) minor-mode-alist)))
|
|
|
148
|
|
|
149 (defun mc-read-mode (&optional arg)
|
|
|
150 "\nMinor mode for interfacing with cryptographic functions.
|
|
|
151 \\<mc-read-mode-map>
|
|
|
152 \\[mc-decrypt]\t\tDecrypt an encrypted message
|
|
|
153 \\[mc-verify]\t\tVerify signature on a clearsigned message
|
|
|
154 \\[mc-snarf]\t\tAdd public key(s) to keyring
|
|
|
155 \\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
|
|
|
156 \\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
|
|
|
157 (interactive)
|
|
|
158 (setq mc-read-mode
|
|
|
159 (if (null arg) (not mc-read-mode)
|
|
|
160 (> (prefix-numeric-value arg) 0)))
|
|
|
161 (and mc-read-mode mc-write-mode (mc-write-mode nil))
|
|
|
162 (if mc-read-mode
|
|
|
163 (easy-menu-add mc-read-mode-menu)
|
|
|
164 (easy-menu-remove mc-read-mode-menu)))
|
|
|
165
|
|
|
166 (defun mc-write-mode (&optional arg)
|
|
|
167 "\nMinor mode for interfacing with cryptographic functions.
|
|
|
168 \\<mc-write-mode-map>
|
|
|
169 \\[mc-encrypt]\t\tEncrypt (and optionally sign) message
|
|
|
170 \\[mc-sign]\t\tClearsign message
|
|
|
171 \\[mc-insert-public-key]\t\tExtract public key from keyring and insert into message
|
|
|
172 \\[mc-pgp-fetch-key]\t\tFetch a PGP key via finger or HTTP
|
|
|
173 \\[mc-remailer-encrypt-for-chain]\t\tEncrypt message for remailing
|
|
|
174 \\[mc-remailer-insert-pseudonym]\t\tInsert a pseudonym (for remailing)
|
|
|
175 \\[mc-remailer-insert-response-block]\t\tInsert a response block (for remailing)
|
|
|
176 \\[mc-deactivate-passwd]\t\tForget passphrase(s)\n"
|
|
|
177 (interactive)
|
|
|
178 (setq mc-write-mode
|
|
|
179 (if (null arg) (not mc-write-mode)
|
|
|
180 (> (prefix-numeric-value arg) 0)))
|
|
|
181 (and mc-write-mode mc-read-mode (mc-read-mode nil))
|
|
|
182 (if mc-write-mode
|
|
|
183 (easy-menu-add mc-write-mode-menu)
|
|
|
184 (easy-menu-remove mc-write-mode-menu)))
|
|
|
185
|
|
|
186 ;;;###autoload
|
|
|
187 (defun mc-install-read-mode ()
|
|
|
188 (interactive)
|
|
|
189 (mc-read-mode 1))
|
|
|
190
|
|
|
191 ;;;###autoload
|
|
|
192 (defun mc-install-write-mode ()
|
|
|
193 (interactive)
|
|
|
194 (mc-write-mode 1))
|
|
|
195
|
|
|
196 ;;}}}
|
|
|
197
|
|
|
198 ;;{{{ Note:
|
|
|
199 ;; The funny triple braces you see are used by `folding-mode', a minor
|
|
|
200 ;; mode by Jamie Lokier, available from the elisp archive.
|
|
|
201 ;;}}}
|
|
|
202
|
|
|
203 ;;{{{ User variables.
|
|
|
204 (defconst mc-version "3.4")
|
|
|
205 (defvar mc-default-scheme 'mc-scheme-pgp "*Default encryption scheme to use.")
|
|
|
206 (defvar mc-passwd-timeout 60
|
|
|
207 "*Time to deactivate password in seconds after a use.
|
|
|
208 nil or 0 means deactivate immediately. If the only timer package available
|
|
|
209 is the 'timer' package, then this can be a string in timer format.")
|
|
|
210
|
|
|
211 (defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME")
|
|
|
212 (user-full-name) "*Your RIPEM user ID."))
|
|
|
213
|
|
|
214 (defvar mc-always-replace nil
|
|
|
215 "*If t, decrypt mail messages in place without prompting.
|
|
|
216
|
|
|
217 If 'never, always use a viewer instead of replacing.")
|
|
|
218
|
|
|
219 (defvar mc-use-default-recipients nil "*Assume that the message should
|
|
|
220 be encoded for everyone listed in the To, Cc, and Bcc fields.")
|
|
|
221
|
|
|
222 (defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with
|
|
|
223 user's public key.")
|
|
|
224
|
|
|
225 (defvar mc-pre-signature-hook nil
|
|
|
226 "*List of hook functions to run immediately before signing.")
|
|
|
227 (defvar mc-post-signature-hook nil
|
|
|
228 "*List of hook functions to run immediately after signing.")
|
|
|
229 (defvar mc-pre-encryption-hook nil
|
|
|
230 "*List of hook functions to run immediately before encrypting.")
|
|
|
231 (defvar mc-post-encryption-hook nil
|
|
|
232 "*List of hook functions to run after encrypting.")
|
|
|
233 (defvar mc-pre-decryption-hook nil
|
|
|
234 "*List of hook functions to run immediately before decrypting.")
|
|
|
235 (defvar mc-post-decryption-hook nil
|
|
|
236 "*List of hook functions to run after decrypting.")
|
|
|
237
|
|
|
238 (defconst mc-buffer-name "*MailCrypt*"
|
|
|
239 "Name of temporary buffer for mailcrypt")
|
|
|
240
|
|
|
241 (defvar mc-modes-alist
|
|
|
242 '((rmail-mode (decrypt . mc-rmail-decrypt-message)
|
|
|
243 (verify . mc-rmail-verify-signature))
|
|
|
244 (rmail-summary-mode (decrypt . mc-rmail-summary-decrypt-message)
|
|
|
245 (verify . mc-rmail-summary-verify-signature)
|
|
|
246 (snarf . mc-rmail-summary-snarf-keys))
|
|
|
247 (vm-mode (decrypt . mc-vm-decrypt-message)
|
|
|
248 (verify . mc-vm-verify-signature)
|
|
|
249 (snarf . mc-vm-snarf-keys))
|
|
|
250 (vm-virtual-mode (decrypt . mc-vm-decrypt-message)
|
|
|
251 (verify . mc-vm-verify-signature)
|
|
|
252 (snarf . mc-vm-snarf-keys))
|
|
|
253 (vm-summary-mode (decrypt . mc-vm-decrypt-message)
|
|
|
254 (verify . mc-vm-verify-signature)
|
|
|
255 (snarf . mc-vm-snarf-keys))
|
|
|
256 (mh-folder-mode (decrypt . mc-mh-decrypt-message)
|
|
|
257 (verify . mc-mh-verify-signature)
|
|
|
258 (snarf . mc-mh-snarf-keys))
|
|
|
259 ;; September Gnus (5.2) has a new message editing mode
|
|
|
260 (message-mode (encrypt . mc-encrypt-message)
|
|
|
261 (sign . mc-sign-message))
|
|
|
262 (gnus-summary-mode (decrypt . mc-gnus-decrypt-message)
|
|
|
263 (verify . mc-gnus-verify-signature)
|
|
|
264 (snarf . mc-gnus-snarf-keys))
|
|
|
265 (gnus-article-mode (decrypt . mc-gnus-decrypt-message)
|
|
|
266 (verify . mc-gnus-verify-signature)
|
|
|
267 (snarf . mc-gnus-snarf-keys))
|
|
|
268 (mail-mode (encrypt . mc-encrypt-message)
|
|
|
269 (sign . mc-sign-message))
|
|
|
270 (vm-mail-mode (encrypt . mc-encrypt-message)
|
|
|
271 (sign . mc-sign-message))
|
|
|
272 (mh-letter-mode (encrypt . mc-encrypt-message)
|
|
|
273 (sign . mc-sign-message))
|
|
|
274 (news-reply-mode (encrypt . mc-encrypt-message)
|
|
|
275 (sign . mc-sign-message)))
|
|
|
276
|
|
|
277 "Association list (indexed by major mode) of association lists
|
|
|
278 (indexed by operation) of functions to call for each major mode.")
|
|
|
279
|
|
|
280 ;;}}}
|
|
|
281 ;;{{{ Program variables and constants.
|
|
|
282
|
|
|
283 (defvar mc-timer nil "Timer object for password deactivation.")
|
|
|
284
|
|
|
285 (defvar mc-passwd-cache nil "Cache for passphrases.")
|
|
|
286
|
|
|
287 (defvar mc-schemes '(("pgp" . mc-scheme-pgp)))
|
|
|
288
|
|
|
289 ;;}}}
|
|
|
290
|
|
|
291 ;;{{{ Utility functions.
|
|
|
292
|
|
|
293 (defun mc-message-delimiter-positions (start-re end-re &optional begin)
|
|
|
294 ;; Returns pair of integers (START . END) that delimit message marked off
|
|
|
295 ;; by the regular expressions start-re and end-re. Optional argument BEGIN
|
|
|
296 ;; determines where we should start looking from.
|
|
|
297 (setq begin (or begin (point-min)))
|
|
|
298 (let (start)
|
|
|
299 (save-excursion
|
|
|
300 (goto-char begin)
|
|
|
301 (and (re-search-forward start-re nil t)
|
|
|
302 (setq start (match-beginning 0))
|
|
|
303 (re-search-forward end-re nil t)
|
|
|
304 (cons start (point))))))
|
|
|
305
|
|
|
306
|
|
|
307 (defun mc-split (regexp str)
|
|
|
308 "Splits STR into a list of elements which were separated by REGEXP,
|
|
|
309 stripping initial and trailing whitespace."
|
|
|
310 (let ((data (match-data))
|
|
|
311 (retval '())
|
|
|
312 beg end)
|
|
|
313 (unwind-protect
|
|
|
314 (progn
|
|
|
315 (string-match "[ \t\n]*" str) ; Will always match at 0
|
|
|
316 (setq beg (match-end 0))
|
|
|
317 (setq end (string-match "[ \t\n]*\\'" str))
|
|
|
318 (while (string-match regexp str beg)
|
|
|
319 (setq retval
|
|
|
320 (cons (substring str beg (match-beginning 0))
|
|
|
321 retval))
|
|
|
322 (setq beg (match-end 0)))
|
|
|
323 (if (not (= (length str) beg)) ; Not end
|
|
|
324 (setq retval (cons (substring str beg end) retval)))
|
|
|
325 (nreverse retval))
|
|
|
326 (store-match-data data))))
|
|
|
327
|
|
|
328 ;;; FIXME - Function never called?
|
|
|
329 ;(defun mc-temp-display (beg end &optional name)
|
|
|
330 ; (let (tmp)
|
|
|
331 ; (if (not name)
|
|
|
332 ; (setq name mc-buffer-name))
|
|
|
333 ; (if (string-match name "*ERROR*")
|
|
|
334 ; (progn
|
|
|
335 ; (message "mailcrypt: An error occured! See *ERROR* buffer.")
|
|
|
336 ; (beep)))
|
|
|
337 ; (setq tmp (buffer-substring beg end))
|
|
|
338 ; (delete-region beg end)
|
|
|
339 ; (save-excursion
|
|
|
340 ; (save-window-excursion
|
|
|
341 ; (with-output-to-temp-buffer name
|
|
|
342 ; (princ tmp))))))
|
|
|
343
|
|
|
344 ;; In case I ever decide to do this right.
|
|
|
345 (defconst mc-field-name-regexp "^\\(.+\\)")
|
|
|
346 (defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)")
|
|
|
347
|
|
|
348 (defun mc-get-fields (&optional matching bounds nuke)
|
|
|
349 "Get all header fields within BOUNDS. Return as an
|
|
|
350 alist ((FIELD-NAME . FIELD-BODY) (FIELD-NAME . FIELD-BODY) ...).
|
|
|
351
|
|
|
352 Argument MATCHING, if present, is a regexp which each FIELD-NAME
|
|
|
353 must match exactly. Matching is case-insensitive.
|
|
|
354
|
|
|
355 Optional arg NUKE, if non-nil, means eliminate all fields returned."
|
|
|
356 (save-excursion
|
|
|
357 (save-restriction
|
|
|
358 (let ((case-fold-search t)
|
|
|
359 (header-field-regexp
|
|
|
360 (concat mc-field-name-regexp ":" mc-field-body-regexp))
|
|
|
361 ret name body field-start field-end)
|
|
|
362 ;; Ensure exact match
|
|
|
363 (if matching
|
|
|
364 (setq matching (concat "^\\(" matching "\\)$")))
|
|
|
365
|
|
|
366 (if bounds
|
|
|
367 (narrow-to-region (car bounds) (cdr bounds)))
|
|
|
368
|
|
|
369 (goto-char (point-max))
|
|
|
370
|
|
|
371 (while (re-search-backward header-field-regexp nil 'move)
|
|
|
372 (setq field-start (match-beginning 0))
|
|
|
373 (setq field-end (match-end 0))
|
|
|
374 (setq name (buffer-substring-no-properties
|
|
|
375 (match-beginning 1) (match-end 1)))
|
|
|
376 (setq body (buffer-substring-no-properties
|
|
|
377 (match-beginning 2) (match-end 2)))
|
|
|
378 (if (or (null matching) (string-match matching name))
|
|
|
379 (progn
|
|
|
380 (setq ret (cons (cons name body) ret))
|
|
|
381 (if nuke
|
|
|
382 (delete-region field-start field-end)))))
|
|
|
383 ret))))
|
|
|
384
|
|
|
385 (defsubst mc-strip-address (addr)
|
|
|
386 "Strip everything from ADDR except the basic Email address."
|
|
|
387 (car (cdr (mail-extract-address-components addr))))
|
|
|
388
|
|
|
389 (defun mc-strip-addresses (addr-list)
|
|
|
390 "Strip everything from the addresses in ADDR-LIST except the basic
|
|
|
391 Email address. ADDR-LIST may be a single string or a list of strings."
|
|
|
392 (if (not (listp addr-list)) (setq addr-list (list addr-list)))
|
|
|
393 (setq addr-list
|
|
|
394 (mapcar
|
|
|
395 (function (lambda (s) (mc-split "\\([ \t\n]*,[ \t\n]*\\)" s)))
|
|
|
396 addr-list))
|
|
|
397 (setq addr-list (apply 'append addr-list))
|
|
|
398 (mapconcat 'mc-strip-address addr-list ", "))
|
|
|
399
|
|
|
400 (defun mc-display-buffer (buffer)
|
|
|
401 "Like display-buffer, but always display top of the buffer."
|
|
|
402 (save-excursion
|
|
|
403 (set-buffer buffer)
|
|
|
404 (goto-char (point-min))
|
|
|
405 (display-buffer buffer)))
|
|
|
406
|
|
|
407 (defun mc-message (msg &optional buffer default)
|
|
|
408 ;; returns t if we used msg, nil if we used default
|
|
|
409 (let ((retval t))
|
|
|
410 (if buffer
|
|
|
411 (setq msg
|
|
|
412 (save-excursion
|
|
|
413 (set-buffer buffer)
|
|
|
414 (goto-char (point-min))
|
|
|
415 (if (re-search-forward msg nil t)
|
|
|
416 (buffer-substring-no-properties
|
|
|
417 (match-beginning 0) (match-end 0))
|
|
|
418 (setq retval nil)
|
|
|
419 default))))
|
|
|
420 (if msg (message "%s" msg))
|
|
|
421 retval))
|
|
|
422
|
|
|
423 (defun mc-process-region (beg end passwd program args parser &optional buffer)
|
|
|
424 (let ((obuf (current-buffer))
|
|
|
425 (process-connection-type nil)
|
|
|
426 mybuf result rgn proc)
|
|
|
427 (unwind-protect
|
|
|
428 (progn
|
|
|
429 (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
|
|
|
430 (set-buffer mybuf)
|
|
|
431 (erase-buffer)
|
|
|
432 (set-buffer obuf)
|
|
|
433 (buffer-disable-undo mybuf)
|
|
|
434 (setq proc
|
|
|
435 (apply 'start-process "*PGP*" mybuf program args))
|
|
|
436 (if passwd
|
|
|
437 (progn
|
|
|
438 (process-send-string proc (concat passwd "\n"))
|
|
|
439 (or mc-passwd-timeout (mc-deactivate-passwd t))))
|
|
|
440 (process-send-region proc beg end)
|
|
|
441 (process-send-eof proc)
|
|
|
442 (while (eq 'run (process-status proc))
|
|
|
443 (accept-process-output proc 5))
|
|
|
444 (setq result (process-exit-status proc))
|
|
|
445 ;; Hack to force a status_notify() in Emacs 19.29
|
|
|
446 (delete-process proc)
|
|
|
447 (set-buffer mybuf)
|
|
|
448 (goto-char (point-max))
|
|
|
449 (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
|
|
|
450 (delete-region (match-beginning 0) (match-end 0)))
|
|
|
451 (goto-char (point-min))
|
|
|
452 ;; CRNL -> NL
|
|
|
453 (while (search-forward "\r\n" nil t)
|
|
|
454 (replace-match "\n"))
|
|
|
455 ;; Hurm. FIXME; must get better result codes.
|
|
|
456 (if (stringp result)
|
|
|
457 (error "%s exited abnormally: '%s'" program result)
|
|
|
458 (setq rgn (funcall parser result))
|
|
|
459 ;; If the parser found something, migrate it
|
|
|
460 (if (consp rgn)
|
|
|
461 (progn
|
|
|
462 (set-buffer obuf)
|
|
|
463 (delete-region beg end)
|
|
|
464 (goto-char beg)
|
|
|
465 (insert-buffer-substring mybuf (car rgn) (cdr rgn))
|
|
|
466 (set-buffer mybuf)
|
|
|
467 (delete-region (car rgn) (cdr rgn)))))
|
|
|
468 ;; Return nil on failure and exit code on success
|
|
|
469 (if rgn result))
|
|
|
470 ;; Cleanup even on nonlocal exit
|
|
|
471 (if (and proc (eq 'run (process-status proc)))
|
|
|
472 (interrupt-process proc))
|
|
|
473 (set-buffer obuf)
|
|
|
474 (or buffer (null mybuf) (kill-buffer mybuf)))))
|
|
|
475
|
|
|
476 ;;}}}
|
|
|
477
|
|
|
478 ;;{{{ Passphrase management
|
|
|
479 (defun mc-activate-passwd (id &optional prompt)
|
|
|
480 "Activate the passphrase matching ID, using PROMPT for a prompt.
|
|
|
481 Return the passphrase. If PROMPT is nil, only return value if cached."
|
|
|
482 (cond ((featurep 'itimer)
|
|
|
483 (if mc-timer (delete-itimer mc-timer))
|
|
|
484 (setq mc-timer (if mc-passwd-timeout
|
|
|
485 (start-itimer "mc-itimer"
|
|
|
486 'mc-deactivate-passwd
|
|
|
487 mc-passwd-timeout)
|
|
|
488 nil)))
|
|
|
489 ((featurep 'timer)
|
|
|
490 (let ((string-time (if (integerp mc-passwd-timeout)
|
|
|
491 (format "%d sec" mc-passwd-timeout)
|
|
|
492 mc-passwd-timeout)))
|
|
|
493 (if mc-timer (cancel-timer mc-timer))
|
|
|
494 (setq mc-timer (if string-time
|
|
|
495 (run-at-time string-time
|
|
|
496 nil 'mc-deactivate-passwd)
|
|
|
497 nil)))))
|
|
|
498 (let ((cell (assoc id mc-passwd-cache))
|
|
|
499 passwd)
|
|
|
500 (setq passwd (cdr-safe cell))
|
|
|
501 (if (and (not passwd) prompt)
|
|
|
502 (setq passwd (comint-read-noecho prompt)))
|
|
|
503 (if cell
|
|
|
504 (setcdr cell passwd)
|
|
|
505 (setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache)))
|
|
|
506 passwd))
|
|
|
507
|
|
|
508 ;;;###autoload
|
|
|
509 (defun mc-deactivate-passwd (&optional inhibit-message)
|
|
|
510 "*Deactivate the passphrase cache."
|
|
|
511 (interactive)
|
|
|
512 (if mc-timer
|
|
|
513 (cond ((featurep 'itimer) (delete-itimer mc-timer))
|
|
|
514 ((featurep 'timer) (cancel-timer mc-timer))))
|
|
|
515 (mapcar
|
|
|
516 (function
|
|
|
517 (lambda (cell)
|
|
|
518 (if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0))
|
|
|
519 (setcdr cell nil)))
|
|
|
520 mc-passwd-cache)
|
|
|
521 (or inhibit-message
|
|
|
522 (not (interactive-p))
|
|
|
523 (message "Passphrase%s deactivated"
|
|
|
524 (if (> (length mc-passwd-cache) 1) "s" ""))))
|
|
|
525
|
|
|
526 ;;}}}
|
|
|
527
|
|
|
528 ;;{{{ Define several aliases so that an apropos on `mailcrypt' will
|
|
|
529 ;; return something.
|
|
|
530 (defalias 'mailcrypt-encrypt 'mc-encrypt)
|
|
|
531 (defalias 'mailcrypt-decrypt 'mc-decrypt)
|
|
|
532 (defalias 'mailcrypt-sign 'mc-sign)
|
|
|
533 (defalias 'mailcrypt-verify 'mc-verify)
|
|
|
534 (defalias 'mailcrypt-insert-public-key 'mc-insert-public-key)
|
|
|
535 (defalias 'mailcrypt-snarf 'mc-snarf)
|
|
|
536 ;;}}}
|
|
|
537 (provide 'mailcrypt)
|
