Mercurial > emacs
comparison lisp/gnus/pgg-gpg.el @ 82951:0fde48feb604
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author | Andreas Schwab <schwab@suse.de> |
---|---|
date | Thu, 22 Jul 2004 16:45:51 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
56503:8bbd2323fbf2 | 82951:0fde48feb604 |
---|---|
1 ;;; pgg-gpg.el --- GnuPG support for PGG. | |
2 | |
3 ;; Copyright (C) 1999, 2000, 2003 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Daiki Ueno <ueno@unixuser.org> | |
6 ;; Created: 1999/10/28 | |
7 ;; Keywords: PGP, OpenPGP, GnuPG | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 ;; Boston, MA 02111-1307, USA. | |
25 | |
26 ;;; Code: | |
27 | |
28 (eval-when-compile | |
29 (require 'cl) ; for gpg macros | |
30 (require 'pgg)) | |
31 | |
32 (defgroup pgg-gpg () | |
33 "GnuPG interface" | |
34 :group 'pgg) | |
35 | |
36 (defcustom pgg-gpg-program "gpg" | |
37 "The GnuPG executable." | |
38 :group 'pgg-gpg | |
39 :type 'string) | |
40 | |
41 (defcustom pgg-gpg-extra-args nil | |
42 "Extra arguments for every GnuPG invocation." | |
43 :group 'pgg-gpg | |
44 :type '(repeat (string :tag "Argument"))) | |
45 | |
46 (defcustom pgg-gpg-recipient-argument "--recipient" | |
47 "GnuPG option to specify recipient." | |
48 :group 'pgg-gpg | |
49 :type '(choice (const :tag "New `--recipient' option" "--recipient") | |
50 (const :tag "Old `--remote-user' option" "--remote-user"))) | |
51 | |
52 (defvar pgg-gpg-user-id nil | |
53 "GnuPG ID of your default identity.") | |
54 | |
55 (defun pgg-gpg-process-region (start end passphrase program args) | |
56 (let* ((output-file-name (pgg-make-temp-file "pgg-output")) | |
57 (args | |
58 `("--status-fd" "2" | |
59 ,@(if passphrase '("--passphrase-fd" "0")) | |
60 "--yes" ; overwrite | |
61 "--output" ,output-file-name | |
62 ,@pgg-gpg-extra-args ,@args)) | |
63 (output-buffer pgg-output-buffer) | |
64 (errors-buffer pgg-errors-buffer) | |
65 (orig-mode (default-file-modes)) | |
66 (process-connection-type nil) | |
67 exit-status) | |
68 (with-current-buffer (get-buffer-create errors-buffer) | |
69 (buffer-disable-undo) | |
70 (erase-buffer)) | |
71 (unwind-protect | |
72 (progn | |
73 (set-default-file-modes 448) | |
74 (let ((coding-system-for-write 'binary) | |
75 (input (buffer-substring-no-properties start end)) | |
76 (default-enable-multibyte-characters nil)) | |
77 (with-temp-buffer | |
78 (when passphrase | |
79 (insert passphrase "\n")) | |
80 (insert input) | |
81 (setq exit-status | |
82 (apply #'call-process-region (point-min) (point-max) program | |
83 nil errors-buffer nil args)))) | |
84 (with-current-buffer (get-buffer-create output-buffer) | |
85 (buffer-disable-undo) | |
86 (erase-buffer) | |
87 (if (file-exists-p output-file-name) | |
88 (let ((coding-system-for-read 'raw-text-dos)) | |
89 (insert-file-contents output-file-name))) | |
90 (set-buffer errors-buffer) | |
91 (if (not (equal exit-status 0)) | |
92 (insert (format "\n%s exited abnormally: '%s'\n" | |
93 program exit-status))))) | |
94 (if (file-exists-p output-file-name) | |
95 (delete-file output-file-name)) | |
96 (set-default-file-modes orig-mode)))) | |
97 | |
98 (defun pgg-gpg-possibly-cache-passphrase (passphrase &optional key) | |
99 (if (and pgg-cache-passphrase | |
100 (progn | |
101 (goto-char (point-min)) | |
102 (re-search-forward "^\\[GNUPG:] GOOD_PASSPHRASE\\>" nil t))) | |
103 (pgg-add-passphrase-cache | |
104 (or key | |
105 (progn | |
106 (goto-char (point-min)) | |
107 (if (re-search-forward | |
108 "^\\[GNUPG:] NEED_PASSPHRASE \\w+ ?\\w*" nil t) | |
109 (substring (match-string 0) -8)))) | |
110 passphrase))) | |
111 | |
112 (defvar pgg-gpg-all-secret-keys 'unknown) | |
113 | |
114 (defun pgg-gpg-lookup-all-secret-keys () | |
115 "Return all secret keys present in secret key ring." | |
116 (when (eq pgg-gpg-all-secret-keys 'unknown) | |
117 (setq pgg-gpg-all-secret-keys '()) | |
118 (let ((args (list "--with-colons" "--no-greeting" "--batch" | |
119 "--list-secret-keys"))) | |
120 (with-temp-buffer | |
121 (apply #'call-process pgg-gpg-program nil t nil args) | |
122 (goto-char (point-min)) | |
123 (while (re-search-forward "^\\(sec\\|pub\\):" nil t) | |
124 (push (substring | |
125 (nth 3 (split-string | |
126 (buffer-substring (match-end 0) | |
127 (progn (end-of-line) (point))) | |
128 ":")) 8) | |
129 pgg-gpg-all-secret-keys))))) | |
130 pgg-gpg-all-secret-keys) | |
131 | |
132 (defun pgg-gpg-lookup-key (string &optional type) | |
133 "Search keys associated with STRING." | |
134 (let ((args (list "--with-colons" "--no-greeting" "--batch" | |
135 (if type "--list-secret-keys" "--list-keys") | |
136 string))) | |
137 (with-temp-buffer | |
138 (apply #'call-process pgg-gpg-program nil t nil args) | |
139 (goto-char (point-min)) | |
140 (if (re-search-forward "^\\(sec\\|pub\\):" nil t) | |
141 (substring | |
142 (nth 3 (split-string | |
143 (buffer-substring (match-end 0) | |
144 (progn (end-of-line)(point))) | |
145 ":")) 8))))) | |
146 | |
147 (defun pgg-gpg-encrypt-region (start end recipients &optional sign) | |
148 "Encrypt the current region between START and END. | |
149 If optional argument SIGN is non-nil, do a combined sign and encrypt." | |
150 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
151 (passphrase | |
152 (when sign | |
153 (pgg-read-passphrase | |
154 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
155 pgg-gpg-user-id))) | |
156 (args | |
157 (append | |
158 (list "--batch" "--armor" "--always-trust" "--encrypt") | |
159 (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) | |
160 (if recipients | |
161 (apply #'nconc | |
162 (mapcar (lambda (rcpt) | |
163 (list pgg-gpg-recipient-argument rcpt)) | |
164 (append recipients | |
165 (if pgg-encrypt-for-me | |
166 (list pgg-gpg-user-id))))))))) | |
167 (pgg-as-lbt start end 'CRLF | |
168 (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) | |
169 (when sign | |
170 (with-current-buffer pgg-errors-buffer | |
171 ;; Possibly cache passphrase under, e.g. "jas", for future sign. | |
172 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
173 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. | |
174 (pgg-gpg-possibly-cache-passphrase passphrase))) | |
175 (pgg-process-when-success))) | |
176 | |
177 (defun pgg-gpg-decrypt-region (start end) | |
178 "Decrypt the current region between START and END." | |
179 (let* ((current-buffer (current-buffer)) | |
180 (message-keys (with-temp-buffer | |
181 (insert-buffer-substring current-buffer) | |
182 (pgg-decode-armor-region (point-min) (point-max)))) | |
183 (secret-keys (pgg-gpg-lookup-all-secret-keys)) | |
184 (key (pgg-gpg-select-matching-key message-keys secret-keys)) | |
185 (pgg-gpg-user-id (or key pgg-gpg-user-id pgg-default-user-id)) | |
186 (passphrase | |
187 (pgg-read-passphrase | |
188 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
189 pgg-gpg-user-id)) | |
190 (args '("--batch" "--decrypt"))) | |
191 (pgg-gpg-process-region start end passphrase pgg-gpg-program args) | |
192 (with-current-buffer pgg-errors-buffer | |
193 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
194 (goto-char (point-min)) | |
195 (re-search-forward "^\\[GNUPG:] DECRYPTION_OKAY\\>" nil t)))) | |
196 | |
197 (defun pgg-gpg-select-matching-key (message-keys secret-keys) | |
198 "Choose a key from MESSAGE-KEYS that matches one of the keys in SECRET-KEYS." | |
199 (loop for message-key in message-keys | |
200 for message-key-id = (and (equal (car message-key) 1) | |
201 (cdr (assq 'key-identifier message-key))) | |
202 for key = (and message-key-id (pgg-lookup-key message-key-id 'encrypt)) | |
203 when (and key (member key secret-keys)) return key)) | |
204 | |
205 (defun pgg-gpg-sign-region (start end &optional cleartext) | |
206 "Make detached signature from text between START and END." | |
207 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
208 (passphrase | |
209 (pgg-read-passphrase | |
210 (format "GnuPG passphrase for %s: " pgg-gpg-user-id) | |
211 pgg-gpg-user-id)) | |
212 (args | |
213 (list (if cleartext "--clearsign" "--detach-sign") | |
214 "--armor" "--batch" "--verbose" | |
215 "--local-user" pgg-gpg-user-id)) | |
216 (inhibit-read-only t) | |
217 buffer-read-only) | |
218 (pgg-as-lbt start end 'CRLF | |
219 (pgg-gpg-process-region start end passphrase pgg-gpg-program args)) | |
220 (with-current-buffer pgg-errors-buffer | |
221 ;; Possibly cache passphrase under, e.g. "jas", for future sign. | |
222 (pgg-gpg-possibly-cache-passphrase passphrase pgg-gpg-user-id) | |
223 ;; Possibly cache passphrase under, e.g. B565716F, for future decrypt. | |
224 (pgg-gpg-possibly-cache-passphrase passphrase)) | |
225 (pgg-process-when-success))) | |
226 | |
227 (defun pgg-gpg-verify-region (start end &optional signature) | |
228 "Verify region between START and END as the detached signature SIGNATURE." | |
229 (let ((args '("--batch" "--verify"))) | |
230 (when (stringp signature) | |
231 (setq args (append args (list signature)))) | |
232 (setq args (append args '("-"))) | |
233 (pgg-gpg-process-region start end nil pgg-gpg-program args) | |
234 (with-current-buffer pgg-errors-buffer | |
235 (goto-char (point-min)) | |
236 (while (re-search-forward "^gpg: \\(.*\\)\n" nil t) | |
237 (with-current-buffer pgg-output-buffer | |
238 (insert-buffer-substring pgg-errors-buffer | |
239 (match-beginning 1) (match-end 0))) | |
240 (delete-region (match-beginning 0) (match-end 0))) | |
241 (goto-char (point-min)) | |
242 (re-search-forward "^\\[GNUPG:] GOODSIG\\>" nil t)))) | |
243 | |
244 (defun pgg-gpg-insert-key () | |
245 "Insert public key at point." | |
246 (let* ((pgg-gpg-user-id (or pgg-gpg-user-id pgg-default-user-id)) | |
247 (args (list "--batch" "--export" "--armor" | |
248 pgg-gpg-user-id))) | |
249 (pgg-gpg-process-region (point)(point) nil pgg-gpg-program args) | |
250 (insert-buffer-substring pgg-output-buffer))) | |
251 | |
252 (defun pgg-gpg-snarf-keys-region (start end) | |
253 "Add all public keys in region between START and END to the keyring." | |
254 (let ((args '("--import" "--batch" "-")) status) | |
255 (pgg-gpg-process-region start end nil pgg-gpg-program args) | |
256 (set-buffer pgg-errors-buffer) | |
257 (goto-char (point-min)) | |
258 (when (re-search-forward "^\\[GNUPG:] IMPORT_RES\\>" nil t) | |
259 (setq status (buffer-substring (match-end 0) | |
260 (progn (end-of-line)(point))) | |
261 status (vconcat (mapcar #'string-to-int (split-string status)))) | |
262 (erase-buffer) | |
263 (insert (format "Imported %d key(s). | |
264 \tArmor contains %d key(s) [%d bad, %d old].\n" | |
265 (+ (aref status 2) | |
266 (aref status 10)) | |
267 (aref status 0) | |
268 (aref status 1) | |
269 (+ (aref status 4) | |
270 (aref status 11))) | |
271 (if (zerop (aref status 9)) | |
272 "" | |
273 "\tSecret keys are imported.\n"))) | |
274 (append-to-buffer pgg-output-buffer (point-min)(point-max)) | |
275 (pgg-process-when-success))) | |
276 | |
277 (provide 'pgg-gpg) | |
278 | |
279 ;;; arch-tag: 2aa5d5d8-93a0-4865-9312-33e29830e000 | |
280 ;;; pgg-gpg.el ends here |