~ubuntu-branches/ubuntu/utopic/mailcrypt/utopic

« back to all changes in this revision

Viewing changes to mailcrypt.el

  • Committer: Bazaar Package Importer
  • Author(s): Davide G. M. Salvetti
  • Date: 2004-02-28 12:11:35 UTC
  • Revision ID: james.westby@ubuntu.com-20040228121135-m0b6y3bqbvhtcdot
Tags: upstream-3.5.8
ImportĀ upstreamĀ versionĀ 3.5.8

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
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>.
 
8
 
 
9
;;{{{ Licensing
 
10
;; This file is intended to be used with GNU Emacs.
 
11
 
 
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)
 
15
;; any later version.
 
16
 
 
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.
 
21
 
 
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.
 
25
;;}}}
 
26
 
 
27
;;{{{ Load some required packages
 
28
 
 
29
(eval-when-compile
 
30
  ;; Quiet warnings
 
31
  (autoload 'start-itimer "itimer")
 
32
  (autoload 'cancel-itimer "itimer")
 
33
  (autoload 'delete-itimer "itimer"))
 
34
 
 
35
(require 'easymenu)
 
36
(require 'comint)
 
37
(require 'rfc822)
 
38
 
 
39
(eval-and-compile
 
40
  (condition-case nil (require 'itimer) (error nil))
 
41
  (if (not (featurep 'itimer))
 
42
      (condition-case nil (require 'timer) (error nil)))
 
43
 
 
44
  (if (not (fboundp 'buffer-substring-no-properties))
 
45
      (fset 'buffer-substring-no-properties 'buffer-substring)))
 
46
 
 
47
(defconst mc-xemacs-p (string-match "XEmacs" emacs-version))
 
48
 
 
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)
 
60
 
 
61
;;}}}
 
62
 
 
63
;;{{{ Minor mode variables and functions
 
64
 
 
65
(defvar mc-pgp-always-sign nil 
 
66
  "*If t, always sign encrypted PGP messages, or never sign if 'never.")
 
67
 
 
68
(defvar mc-read-mode nil
 
69
  "Non-nil means Mailcrypt read mode key bindings are available.")
 
70
 
 
71
(defvar mc-write-mode nil
 
72
  "Non-nil means Mailcrypt write mode key bindings are available.")
 
73
 
 
74
(make-variable-buffer-local 'mc-read-mode)
 
75
(make-variable-buffer-local 'mc-write-mode)
 
76
 
 
77
(defvar mc-read-mode-string " MC-r"
 
78
  "*String to put in mode line when Mailcrypt read mode is active.")
 
79
 
 
80
(defvar mc-write-mode-string " MC-w"
 
81
  "*String to put in mode line when Mailcrypt write mode is active.")
 
82
 
 
83
(defvar mc-read-mode-map nil
 
84
  "Keymap for Mailcrypt read mode bindings.")
 
85
 
 
86
(defvar mc-write-mode-map nil
 
87
  "Keymap for Mailcrypt write mode bindings.")
 
88
 
 
89
(or mc-read-mode-map
 
90
    (progn
 
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)))
 
97
 
 
98
(or mc-write-mode-map
 
99
    (progn
 
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)))
 
112
 
 
113
(easy-menu-define
 
114
 mc-read-mode-menu (if mc-xemacs-p nil (list mc-read-mode-map))
 
115
 "Mailcrypt read mode menu."
 
116
 '("Mailcrypt"
 
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]))
 
122
 
 
123
(easy-menu-define
 
124
 mc-write-mode-menu (if mc-xemacs-p nil (list mc-write-mode-map))
 
125
 "Mailcrypt write mode menu."
 
126
 '("Mailcrypt"
 
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]))
 
135
 
 
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)))
 
140
 
 
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)))
 
145
 
 
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)))
 
149
 
 
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)))
 
153
 
 
154
(defun mc-read-mode (&optional arg)
 
155
  "\nMinor mode for interfacing with cryptographic functions.
 
156
\\<mc-read-mode-map>
 
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"
 
162
  (interactive)
 
163
  (setq mc-read-mode
 
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))
 
167
  (if mc-read-mode
 
168
      (easy-menu-add mc-read-mode-menu)
 
169
    (easy-menu-remove mc-read-mode-menu)))
 
170
        
 
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"
 
182
  (interactive)
 
183
  (setq mc-write-mode
 
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))
 
187
  (if mc-write-mode
 
188
      (easy-menu-add mc-write-mode-menu)
 
189
    (easy-menu-remove mc-write-mode-menu)))
 
190
 
 
191
(defun mc-install-read-mode ()
 
192
  (interactive)
 
193
  (mc-read-mode 1))
 
194
 
 
195
(defun mc-install-write-mode ()
 
196
  (interactive)
 
197
  (mc-write-mode 1))
 
198
 
 
199
;;}}}
 
200
 
 
201
;;{{{ Note:
 
202
;; The funny triple braces you see are used by `folding-mode', a minor
 
203
;; mode by Jamie Lokier, available from the elisp archive.
 
204
;;}}}
 
205
 
 
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)
 
211
        ("/tmp/"))
 
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.")
 
218
 
 
219
(defvar mc-ripem-user-id (or (getenv "RIPEM_USER_NAME")
 
220
                             (user-full-name) "*Your RIPEM user ID."))
 
221
 
 
222
(defvar mc-always-replace nil
 
223
  "*If t, decrypt mail messages in place without prompting.
 
224
 
 
225
If 'never, always use a viewer instead of replacing.")
 
226
 
 
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.")
 
229
 
 
230
(defvar mc-encrypt-for-me nil "*Encrypt all outgoing messages with
 
231
  user's public key.")
 
232
 
 
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.")
 
245
 
 
246
(defconst mc-buffer-name "*MailCrypt*"
 
247
  "Name of temporary buffer for mailcrypt")
 
248
 
 
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)))
 
289
 
 
290
  "Association list (indexed by major mode) of association lists
 
291
(indexed by operation) of functions to call for each major mode.")
 
292
 
 
293
;;}}}
 
294
;;{{{ Program variables and constants.
 
295
 
 
296
(defvar mc-timer nil "Timer object for password deactivation.")
 
297
 
 
298
(defvar mc-passwd-cache nil "Cache for passphrases.")
 
299
 
 
300
(defvar mc-schemes '(("pgp50" . mc-scheme-pgp50)
 
301
                     ("pgp" . mc-scheme-pgp)
 
302
                     ("gpg" . mc-scheme-gpg)
 
303
                     ))
 
304
 
 
305
;;}}}
 
306
 
 
307
;;{{{ Utility functions.
 
308
 
 
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)))
 
314
  (let (start)
 
315
    (save-excursion
 
316
      (goto-char begin)
 
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))))))
 
321
 
 
322
 
 
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))
 
327
        (retval '())
 
328
        beg end)
 
329
    (unwind-protect
 
330
        (progn
 
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)
 
335
            (setq retval
 
336
                  (cons (substring str beg (match-beginning 0)) 
 
337
                        retval))
 
338
            (setq beg (match-end 0)))
 
339
          (if (not (= (length str) beg)) ; Not end
 
340
              (setq retval (cons (substring str beg end) retval)))
 
341
          (nreverse retval))
 
342
      (store-match-data data))))
 
343
 
 
344
;;; FIXME - Function never called?
 
345
;(defun mc-temp-display (beg end &optional name)
 
346
;  (let (tmp)
 
347
;    (if (not name)
 
348
;       (setq name mc-buffer-name))
 
349
;    (if (string-match name "*ERROR*")
 
350
;       (progn
 
351
;         (message "mailcrypt: An error occured!  See *ERROR* buffer.")
 
352
;         (beep)))
 
353
;    (setq tmp (buffer-substring beg end))
 
354
;    (delete-region beg end)
 
355
;    (save-excursion
 
356
;      (save-window-excursion
 
357
;       (with-output-to-temp-buffer name
 
358
;         (princ tmp))))))
 
359
 
 
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 
 
365
  (concat 
 
366
   "^\\([" 
 
367
   (char-to-string 33) "-" (char-to-string 57)
 
368
   (char-to-string 59) "-" (char-to-string 126)
 
369
   "]*\\)"))
 
370
(defconst mc-field-body-regexp "\\(.*\\(\n[ \t].*\\)*\n\\)")
 
371
 
 
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) ...).
 
375
 
 
376
Argument MATCHING, if present, is a regexp which each FIELD-NAME
 
377
must match exactly.  Matching is case-insensitive.
 
378
 
 
379
Optional arg NUKE, if non-nil, means eliminate all fields returned."
 
380
  (save-excursion
 
381
    (save-restriction
 
382
      (let ((case-fold-search t)
 
383
            (header-field-regexp
 
384
             (concat mc-field-name-regexp ":" mc-field-body-regexp))
 
385
            ret name body field-start field-end)
 
386
        ;; Ensure exact match
 
387
        (if matching
 
388
            (setq matching (concat "^\\(" matching "\\)$")))
 
389
 
 
390
        (if bounds
 
391
            (narrow-to-region (car bounds) (cdr bounds)))
 
392
 
 
393
        (goto-char (point-max))
 
394
 
 
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))
 
403
              (progn
 
404
                (setq ret (cons (cons name body) ret))
 
405
                (if nuke
 
406
                    (delete-region field-start field-end)))))
 
407
        ret))))
 
408
 
 
409
(defsubst mc-strip-address (addr)
 
410
  "Strip everything from ADDR except the basic Email address."
 
411
  (car (rfc822-addresses addr)))
 
412
 
 
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)))
 
417
  (setq addr-list
 
418
        (mapcar
 
419
         (function (lambda (s) (rfc822-addresses s)))
 
420
         addr-list))
 
421
  (setq addr-list (apply 'append addr-list))
 
422
  (mapconcat 'mc-strip-address addr-list ", "))
 
423
 
 
424
(defun mc-display-buffer (buffer)
 
425
  "Like display-buffer, but always display top of the buffer."
 
426
  (save-excursion
 
427
    (set-buffer buffer)
 
428
    (goto-char (point-min))
 
429
    (display-buffer buffer)))
 
430
 
 
431
(defun mc-message (msg &optional buffer default)
 
432
  ;; returns t if we used msg, nil if we used default
 
433
  (let ((retval t))
 
434
    (if buffer
 
435
        (setq msg
 
436
              (save-excursion
 
437
                (set-buffer buffer)
 
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))
 
442
                  (setq retval nil)
 
443
                  default))))
 
444
    (if msg (message-or-box "%s" msg))
 
445
    retval))
 
446
 
 
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)
 
452
)
 
453
 
 
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)
 
458
    (unwind-protect
 
459
        (progn
 
460
          (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
 
461
          (set-buffer mybuf)
 
462
          (erase-buffer)
 
463
          (set-buffer obuf)
 
464
          (buffer-disable-undo mybuf)
 
465
          (setq proc
 
466
                (apply 'start-process "*PGP*" mybuf program args))
 
467
          (if passwd
 
468
              (progn
 
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)
 
478
          (set-buffer mybuf)
 
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))
 
483
          ;; CRNL -> NL
 
484
          (while (search-forward "\r\n" nil t)
 
485
            (replace-match "\n"))
 
486
          ;; Hurm.  FIXME; must get better result codes.
 
487
          (if (stringp result)
 
488
              (error "%s exited abnormally: '%s'" program result)
 
489
            (setq rgn (funcall parser result))
 
490
            ;; If the parser found something, migrate it
 
491
            (if (consp rgn)
 
492
                (progn
 
493
                  (set-buffer obuf)
 
494
                  (delete-region beg end)
 
495
                  (goto-char beg)
 
496
                  (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 
497
                  (set-buffer mybuf)
 
498
                  (delete-region (car rgn) (cdr rgn)))))
 
499
          ;; Return nil on failure and exit code on success
 
500
          (if rgn result))
 
501
      ;; Cleanup even on nonlocal exit
 
502
      (if (and proc (eq 'run (process-status proc)))
 
503
          (interrupt-process proc))
 
504
      (set-buffer obuf)
 
505
      (or buffer (null mybuf) (kill-buffer mybuf)))))
 
506
 
 
507
;;}}}
 
508
 
 
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
 
518
                                          mc-passwd-timeout)
 
519
                          nil)))
 
520
        ((featurep 'timer)
 
521
         (let ((string-time (if (integerp mc-passwd-timeout)
 
522
                                (format "%d sec" mc-passwd-timeout)
 
523
                              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)
 
528
                            nil)))))
 
529
  (let ((cell (assoc id mc-passwd-cache))
 
530
        passwd)
 
531
    (setq passwd (cdr-safe cell))
 
532
    (if (and (not passwd) prompt)
 
533
        (setq passwd (comint-read-noecho prompt)))
 
534
    (if cell
 
535
        (setcdr cell passwd)
 
536
      (setq mc-passwd-cache (cons (cons id passwd) mc-passwd-cache)))
 
537
    passwd))
 
538
 
 
539
(defun mc-deactivate-passwd (&optional inhibit-message)
 
540
  "*Deactivate the passphrase cache."
 
541
  (interactive)
 
542
  (if mc-timer
 
543
      (cond ((featurep 'itimer) (delete-itimer mc-timer))
 
544
            ((featurep 'timer) (cancel-timer mc-timer))))
 
545
  (mapcar
 
546
   (function
 
547
    (lambda (cell)
 
548
      (if (stringp (cdr-safe cell)) (fillarray (cdr cell) 0))
 
549
      (setcdr cell nil)))
 
550
   mc-passwd-cache)
 
551
  (or inhibit-message
 
552
      (not (interactive-p))
 
553
      (message "Passphrase%s deactivated"
 
554
               (if (> (length mc-passwd-cache) 1) "s" ""))))
 
555
 
 
556
;;}}}
 
557
 
 
558
;;{{{ Define several aliases so that an apropos on `mailcrypt' will
 
559
;; return something.
 
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)
 
566
;;}}}
 
567
 
 
568
(provide 'mailcrypt)