1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Sascha Lüdecke <sascha@meta-x.de>,
7 ;; Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs 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 3 of the License, or
15 ;; (at your option) any later version.
17 ;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
31 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
)))
33 (if (locate-library "password-cache")
34 (require 'password-cache
)
44 (defvar mc-pgp-always-sign
)
46 (autoload 'quoted-printable-decode-region
"qp")
47 (autoload 'quoted-printable-encode-region
"qp")
49 (autoload 'mm-decode-content-transfer-encoding
"mm-bodies")
50 (autoload 'mm-encode-content-transfer-encoding
"mm-bodies")
51 (autoload 'message-options-get
"message")
52 (autoload 'message-options-set
"message")
54 (defvar mml1991-use mml2015-use
55 "The package used for PGP.")
57 (defvar mml1991-function-alist
58 '((mailcrypt mml1991-mailcrypt-sign
59 mml1991-mailcrypt-encrypt
)
66 "Alist of PGP functions.")
68 (defvar mml1991-verbose mml-secure-verbose
69 "If non-nil, ask the user about the current operation more verbosely.")
71 (defvar mml1991-cache-passphrase mml-secure-cache-passphrase
72 "If t, cache passphrase.")
74 (defvar mml1991-passphrase-cache-expiry mml-secure-passphrase-cache-expiry
75 "How many seconds the passphrase is cached.
76 Whether the passphrase is cached at all is controlled by
77 `mml1991-cache-passphrase'.")
79 (defvar mml1991-signers nil
80 "A list of your own key ID which will be used to sign a message.")
82 (defvar mml1991-encrypt-to-self nil
83 "If t, add your own key ID to recipient list when encryption.")
87 (autoload 'mc-sign-generic
"mc-toplev")
89 (defvar mml1991-decrypt-function
'mailcrypt-decrypt
)
90 (defvar mml1991-verify-function
'mailcrypt-verify
)
92 (defun mml1991-mailcrypt-sign (cont)
93 (let ((text (current-buffer))
95 (result-buffer (get-buffer-create "*GPG Result*")))
96 ;; Save MIME Content[^ ]+: headers from signing
97 (goto-char (point-min))
98 (while (looking-at "^Content[^ ]+:") (forward-line))
100 (setq headers
(buffer-string))
101 (delete-region (point-min) (point)))
102 (goto-char (point-max))
105 (quoted-printable-decode-region (point-min) (point-max))
107 (setq signature
(current-buffer))
108 (insert-buffer-substring text
)
109 (unless (mc-sign-generic (message-options-get 'message-sender
)
111 (unless (> (point-max) (point-min))
112 (pop-to-buffer result-buffer
)
113 (error "Sign error")))
114 (goto-char (point-min))
115 (while (re-search-forward "\r+$" nil t
)
116 (replace-match "" t t
))
117 (quoted-printable-encode-region (point-min) (point-max))
119 (delete-region (point-min) (point-max))
120 (if headers
(insert headers
))
122 (insert-buffer-substring signature
)
123 (goto-char (point-max)))))
125 (declare-function mc-encrypt-generic
"ext:mc-toplev"
126 (&optional recipients scheme start end from sign
))
128 (defun mml1991-mailcrypt-encrypt (cont &optional sign
)
129 (let ((text (current-buffer))
131 (or mc-pgp-always-sign
133 (eq t
(or (message-options-get 'message-sign-encrypt
)
135 'message-sign-encrypt
136 (or (y-or-n-p "Sign the message? ")
140 (result-buffer (get-buffer-create "*GPG Result*")))
141 ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
142 (goto-char (point-min))
143 (while (looking-at "^Content[^ ]+:") (forward-line))
145 (delete-region (point-min) (point)))
146 (mm-with-unibyte-current-buffer
148 (inline (mm-disable-multibyte))
149 (setq cipher
(current-buffer))
150 (insert-buffer-substring text
)
151 (unless (mc-encrypt-generic
153 (message-options-get 'message-recipients
)
154 (message-options-set 'message-recipients
155 (read-string "Recipients: ")))
157 (point-min) (point-max)
158 (message-options-get 'message-sender
)
160 (unless (> (point-max) (point-min))
161 (pop-to-buffer result-buffer
)
162 (error "Encrypt error")))
163 (goto-char (point-min))
164 (while (re-search-forward "\r+$" nil t
)
165 (replace-match "" t t
))
167 (delete-region (point-min) (point-max))
168 ;;(insert "Content-Type: application/pgp-encrypted\n\n")
169 ;;(insert "Version: 1\n\n")
171 (insert-buffer-substring cipher
)
172 (goto-char (point-max))))))
176 (autoload 'gpg-sign-cleartext
"gpg")
178 (declare-function gpg-sign-encrypt
"ext:gpg"
179 (plaintext ciphertext result recipients
&optional
180 passphrase sign-with-key armor textmode
))
181 (declare-function gpg-encrypt
"ext:gpg"
182 (plaintext ciphertext result recipients
&optional
183 passphrase armor textmode
))
185 (defun mml1991-gpg-sign (cont)
186 (let ((text (current-buffer))
188 (result-buffer (get-buffer-create "*GPG Result*")))
189 ;; Save MIME Content[^ ]+: headers from signing
190 (goto-char (point-min))
191 (while (looking-at "^Content[^ ]+:") (forward-line))
193 (setq headers
(buffer-string))
194 (delete-region (point-min) (point)))
195 (goto-char (point-max))
198 (quoted-printable-decode-region (point-min) (point-max))
200 (unless (gpg-sign-cleartext text
(setq signature
(current-buffer))
203 (message-options-get 'message-sender
))
204 (unless (> (point-max) (point-min))
205 (pop-to-buffer result-buffer
)
206 (error "Sign error")))
207 (goto-char (point-min))
208 (while (re-search-forward "\r+$" nil t
)
209 (replace-match "" t t
))
210 (quoted-printable-encode-region (point-min) (point-max))
212 (delete-region (point-min) (point-max))
213 (if headers
(insert headers
))
215 (insert-buffer-substring signature
)
216 (goto-char (point-max)))))
218 (defun mml1991-gpg-encrypt (cont &optional sign
)
219 (let ((text (current-buffer))
221 (result-buffer (get-buffer-create "*GPG Result*")))
222 ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMORED
223 (goto-char (point-min))
224 (while (looking-at "^Content[^ ]+:") (forward-line))
226 (delete-region (point-min) (point)))
227 (mm-with-unibyte-current-buffer
229 (inline (mm-disable-multibyte))
230 (flet ((gpg-encrypt-func
231 (sign plaintext ciphertext result recipients
&optional
232 passphrase sign-with-key armor textmode
)
235 plaintext ciphertext result recipients passphrase
236 sign-with-key armor textmode
)
238 plaintext ciphertext result recipients passphrase
240 (unless (gpg-encrypt-func
242 text
(setq cipher
(current-buffer))
246 (message-options-get 'message-recipients
)
247 (message-options-set 'message-recipients
248 (read-string "Recipients: ")))
251 (message-options-get 'message-sender
)
252 t t
) ; armor & textmode
253 (unless (> (point-max) (point-min))
254 (pop-to-buffer result-buffer
)
255 (error "Encrypt error"))))
256 (goto-char (point-min))
257 (while (re-search-forward "\r+$" nil t
)
258 (replace-match "" t t
))
260 (delete-region (point-min) (point-max))
261 ;;(insert "Content-Type: application/pgp-encrypted\n\n")
262 ;;(insert "Version: 1\n\n")
264 (insert-buffer-substring cipher
)
265 (goto-char (point-max))))))
269 (defvar pgg-default-user-id
)
270 (defvar pgg-errors-buffer
)
271 (defvar pgg-output-buffer
)
273 (defun mml1991-pgg-sign (cont)
274 (let ((pgg-text-mode t
)
275 (pgg-default-user-id (or (message-options-get 'mml-sender
)
276 pgg-default-user-id
))
278 ;; Don't sign headers.
279 (goto-char (point-min))
280 (when (re-search-forward "^$" nil t
)
281 (setq headers
(buffer-substring (point-min) (point)))
283 (narrow-to-region (point-min) (point))
284 (setq cte
(mail-fetch-field "content-transfer-encoding")))
286 (delete-region (point-min) (point))
288 (setq cte
(intern (downcase cte
)))
289 (mm-decode-content-transfer-encoding cte
)))
290 (unless (pgg-sign-region (point-min) (point-max) t
)
291 (pop-to-buffer pgg-errors-buffer
)
292 (error "Encrypt error"))
293 (delete-region (point-min) (point-max))
294 (mm-with-unibyte-current-buffer
295 (insert-buffer-substring pgg-output-buffer
)
296 (goto-char (point-min))
297 (while (re-search-forward "\r+$" nil t
)
298 (replace-match "" t t
))
300 (mm-encode-content-transfer-encoding cte
))
301 (goto-char (point-min))
307 (defun mml1991-pgg-encrypt (cont &optional sign
)
308 (goto-char (point-min))
309 (when (re-search-forward "^$" nil t
)
310 (let ((cte (save-restriction
311 (narrow-to-region (point-min) (point))
312 (mail-fetch-field "content-transfer-encoding"))))
313 ;; Strip MIME headers since it will be ASCII armored.
315 (delete-region (point-min) (point))
317 (mm-decode-content-transfer-encoding (intern (downcase cte
))))))
318 (unless (let ((pgg-text-mode t
))
320 (point-min) (point-max)
323 (message-options-get 'message-recipients
)
324 (message-options-set 'message-recipients
325 (read-string "Recipients: ")))
328 (pop-to-buffer pgg-errors-buffer
)
329 (error "Encrypt error"))
330 (delete-region (point-min) (point-max))
332 (insert-buffer-substring pgg-output-buffer
)
337 (defvar epg-user-id-alist
)
339 (autoload 'epg-make-context
"epg")
340 (autoload 'epg-passphrase-callback-function
"epg")
341 (autoload 'epa-select-keys
"epa")
342 (autoload 'epg-list-keys
"epg")
343 (autoload 'epg-context-set-armor
"epg")
344 (autoload 'epg-context-set-textmode
"epg")
345 (autoload 'epg-context-set-signers
"epg")
346 (autoload 'epg-context-set-passphrase-callback
"epg")
347 (autoload 'epg-sign-string
"epg")
348 (autoload 'epg-encrypt-string
"epg")
349 (autoload 'epg-configuration
"epg-config")
350 (autoload 'epg-expand-group
"epg-config")
352 (defvar mml1991-epg-secret-key-id-list nil
)
354 (defun mml1991-epg-passphrase-callback (context key-id ignore
)
356 (epg-passphrase-callback-function context key-id nil
)
357 (let* ((entry (assoc key-id epg-user-id-alist
))
360 (format "GnuPG passphrase for %s: "
368 (let ((password-cache-expiry mml1991-passphrase-cache-expiry
))
369 (password-cache-add key-id passphrase
))
370 (setq mml1991-epg-secret-key-id-list
371 (cons key-id mml1991-epg-secret-key-id-list
))
372 (copy-sequence passphrase
)))))
374 (defun mml1991-epg-sign (cont)
375 (let ((context (epg-make-context))
376 headers cte signers signature
)
377 (if (eq mm-sign-option
'guided
)
378 (setq signers
(epa-select-keys context
"Select keys for signing.
379 If no one is selected, default secret key is used. "
382 (setq signers
(mapcar (lambda (name)
383 (car (epg-list-keys context name t
)))
385 (epg-context-set-armor context t
)
386 (epg-context-set-textmode context t
)
387 (epg-context-set-signers context signers
)
388 (if mml1991-cache-passphrase
389 (epg-context-set-passphrase-callback
391 #'mml1991-epg-passphrase-callback
))
392 ;; Don't sign headers.
393 (goto-char (point-min))
394 (when (re-search-forward "^$" nil t
)
395 (setq headers
(buffer-substring (point-min) (point)))
397 (narrow-to-region (point-min) (point))
398 (setq cte
(mail-fetch-field "content-transfer-encoding")))
400 (delete-region (point-min) (point))
402 (setq cte
(intern (downcase cte
)))
403 (mm-decode-content-transfer-encoding cte
)))
404 (condition-case error
405 (setq signature
(epg-sign-string context
(buffer-string) 'clear
)
406 mml1991-epg-secret-key-id-list nil
)
408 (while mml1991-epg-secret-key-id-list
409 (password-cache-remove (car mml1991-epg-secret-key-id-list
))
410 (setq mml1991-epg-secret-key-id-list
411 (cdr mml1991-epg-secret-key-id-list
)))
412 (signal (car error
) (cdr error
))))
413 (delete-region (point-min) (point-max))
414 (mm-with-unibyte-current-buffer
416 (goto-char (point-min))
417 (while (re-search-forward "\r+$" nil t
)
418 (replace-match "" t t
))
420 (mm-encode-content-transfer-encoding cte
))
421 (goto-char (point-min))
427 (defun mml1991-epg-encrypt (cont &optional sign
)
428 (goto-char (point-min))
429 (when (re-search-forward "^$" nil t
)
430 (let ((cte (save-restriction
431 (narrow-to-region (point-min) (point))
432 (mail-fetch-field "content-transfer-encoding"))))
433 ;; Strip MIME headers since it will be ASCII armored.
435 (delete-region (point-min) (point))
437 (mm-decode-content-transfer-encoding (intern (downcase cte
))))))
438 (let ((context (epg-make-context))
440 (if (message-options-get 'message-recipients
)
442 (message-options-get 'message-recipients
)
444 cipher signers config
)
445 ;; We should remove this check if epg-0.0.6 is released.
446 (if (and (condition-case nil
447 (require 'epg-config
)
449 (functionp #'epg-expand-group
))
450 (setq config
(epg-configuration)
453 (mapcar (lambda (recipient)
454 (or (epg-expand-group config recipient
)
457 (if (eq mm-encrypt-option
'guided
)
459 (epa-select-keys context
"Select recipients for encryption.
460 If no one is selected, symmetric encryption will be performed. "
463 (delq nil
(mapcar (lambda (name)
464 (car (epg-list-keys context name
)))
466 (if mml1991-encrypt-to-self
470 (mapcar (lambda (name)
471 (car (epg-list-keys context name
)))
473 (error "mml1991-signers not set")))
475 (if (eq mm-sign-option
'guided
)
476 (setq signers
(epa-select-keys context
"Select keys for signing.
477 If no one is selected, default secret key is used. "
480 (setq signers
(mapcar (lambda (name)
481 (car (epg-list-keys context name t
)))
483 (epg-context-set-signers context signers
))
484 (epg-context-set-armor context t
)
485 (epg-context-set-textmode context t
)
486 (if mml1991-cache-passphrase
487 (epg-context-set-passphrase-callback
489 #'mml1991-epg-passphrase-callback
))
490 (condition-case error
492 (epg-encrypt-string context
(buffer-string) recipients sign
)
493 mml1991-epg-secret-key-id-list nil
)
495 (while mml1991-epg-secret-key-id-list
496 (password-cache-remove (car mml1991-epg-secret-key-id-list
))
497 (setq mml1991-epg-secret-key-id-list
498 (cdr mml1991-epg-secret-key-id-list
)))
499 (signal (car error
) (cdr error
))))
500 (delete-region (point-min) (point-max))
501 (insert "\n" cipher
))
505 (defun mml1991-encrypt (cont &optional sign
)
506 (let ((func (nth 2 (assq mml1991-use mml1991-function-alist
))))
508 (funcall func cont sign
)
509 (error "Cannot find encrypt function"))))
512 (defun mml1991-sign (cont)
513 (let ((func (nth 1 (assq mml1991-use mml1991-function-alist
))))
516 (error "Cannot find sign function"))))
521 ;; coding: iso-8859-1
524 ;;; mml1991.el ends here