* lpath.el: Fbind string-as-multibyte for XEmacs.
[gnus] / lisp / mml1991.el
1 ;;; mml1991.el --- Old PGP message format (RFC 1991) support for MML
2
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;;   2005, 2006 Free Software Foundation, Inc.
5
6 ;; Author: Sascha L├╝decke <sascha@meta-x.de>,
7 ;;      Simon Josefsson <simon@josefsson.org> (Mailcrypt interface, Gnus glue)
8 ;; Keywords PGP
9
10 ;; This file is part of GNU Emacs.
11
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 2, or (at your option)
15 ;; any later version.
16
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.
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 the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
26
27 ;;; Commentary:
28
29 ;;; Code:
30
31 (eval-when-compile
32   (require 'cl)
33   (require 'mm-util))
34
35 (defvar mc-pgp-always-sign)
36
37 (autoload 'quoted-printable-decode-region "qp")
38 (autoload 'quoted-printable-encode-region "qp")
39
40 (defvar mml1991-use mml2015-use
41   "The package used for PGP.")
42
43 (defvar mml1991-function-alist
44   '((mailcrypt mml1991-mailcrypt-sign
45                mml1991-mailcrypt-encrypt)
46     (gpg mml1991-gpg-sign
47          mml1991-gpg-encrypt)
48     (pgg mml1991-pgg-sign
49          mml1991-pgg-encrypt))
50   "Alist of PGP functions.")
51
52 ;;; mailcrypt wrapper
53
54 (eval-and-compile
55   (autoload 'mc-sign-generic "mc-toplev"))
56
57 (defvar mml1991-decrypt-function 'mailcrypt-decrypt)
58 (defvar mml1991-verify-function 'mailcrypt-verify)
59
60 (defun mml1991-mailcrypt-sign (cont)
61   (let ((text (current-buffer))
62         headers signature
63         (result-buffer (get-buffer-create "*GPG Result*")))
64     ;; Save MIME Content[^ ]+: headers from signing
65     (goto-char (point-min))
66     (while (looking-at "^Content[^ ]+:") (forward-line))
67     (unless (bobp)
68       (setq headers (buffer-string))
69       (delete-region (point-min) (point)))
70     (goto-char (point-max))
71     (unless (bolp)
72       (insert "\n"))
73     (quoted-printable-decode-region (point-min) (point-max))
74     (with-temp-buffer
75       (setq signature (current-buffer))
76       (insert-buffer-substring text)
77       (unless (mc-sign-generic (message-options-get 'message-sender)
78                                nil nil nil nil)
79         (unless (> (point-max) (point-min))
80           (pop-to-buffer result-buffer)
81           (error "Sign error")))
82       (goto-char (point-min))
83       (while (re-search-forward "\r+$" nil t)
84         (replace-match "" t t))
85       (quoted-printable-encode-region (point-min) (point-max))
86       (set-buffer text)
87       (delete-region (point-min) (point-max))
88       (if headers (insert headers))
89       (insert "\n")
90       (insert-buffer-substring signature)
91       (goto-char (point-max)))))
92
93 (defun mml1991-mailcrypt-encrypt (cont &optional sign)
94   (let ((text (current-buffer))
95         (mc-pgp-always-sign
96          (or mc-pgp-always-sign
97              sign
98              (eq t (or (message-options-get 'message-sign-encrypt)
99                        (message-options-set
100                         'message-sign-encrypt
101                         (or (y-or-n-p "Sign the message? ")
102                             'not))))
103              'never))
104         cipher
105         (result-buffer (get-buffer-create "*GPG Result*")))
106     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
107     (goto-char (point-min))
108     (while (looking-at "^Content[^ ]+:") (forward-line))
109     (unless (bobp)
110       (delete-region (point-min) (point)))
111     (mm-with-unibyte-current-buffer
112       (with-temp-buffer
113         (setq cipher (current-buffer))
114         (insert-buffer-substring text)
115         (unless (mc-encrypt-generic
116                  (or
117                   (message-options-get 'message-recipients)
118                   (message-options-set 'message-recipients
119                                        (read-string "Recipients: ")))
120                  nil
121                  (point-min) (point-max)
122                  (message-options-get 'message-sender)
123                  'sign)
124           (unless (> (point-max) (point-min))
125             (pop-to-buffer result-buffer)
126             (error "Encrypt error")))
127         (goto-char (point-min))
128         (while (re-search-forward "\r+$" nil t)
129           (replace-match "" t t))
130         (set-buffer text)
131         (delete-region (point-min) (point-max))
132         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
133         ;;(insert "Version: 1\n\n")
134         (insert "\n")
135         (insert-buffer-substring cipher)
136         (goto-char (point-max))))))
137
138 ;;; gpg wrapper
139
140 (eval-and-compile
141   (autoload 'gpg-sign-cleartext "gpg"))
142
143 (defun mml1991-gpg-sign (cont)
144   (let ((text (current-buffer))
145         headers signature
146         (result-buffer (get-buffer-create "*GPG Result*")))
147     ;; Save MIME Content[^ ]+: headers from signing
148     (goto-char (point-min))
149     (while (looking-at "^Content[^ ]+:") (forward-line))
150     (unless (bobp)
151       (setq headers (buffer-string))
152       (delete-region (point-min) (point)))
153     (goto-char (point-max))
154     (unless (bolp)
155       (insert "\n"))
156     (quoted-printable-decode-region (point-min) (point-max))
157     (with-temp-buffer
158       (unless (gpg-sign-cleartext text (setq signature (current-buffer))
159                                   result-buffer
160                                   nil
161                                   (message-options-get 'message-sender))
162         (unless (> (point-max) (point-min))
163           (pop-to-buffer result-buffer)
164           (error "Sign error")))
165       (goto-char (point-min))
166       (while (re-search-forward "\r+$" nil t)
167         (replace-match "" t t))
168       (quoted-printable-encode-region (point-min) (point-max))
169       (set-buffer text)
170       (delete-region (point-min) (point-max))
171       (if headers (insert headers))
172       (insert "\n")
173       (insert-buffer-substring signature)
174       (goto-char (point-max)))))
175
176 (defun mml1991-gpg-encrypt (cont &optional sign)
177   (let ((text (current-buffer))
178         cipher
179         (result-buffer (get-buffer-create "*GPG Result*")))
180     ;; Strip MIME Content[^ ]: headers since it will be ASCII ARMOURED
181     (goto-char (point-min))
182     (while (looking-at "^Content[^ ]+:") (forward-line))
183     (unless (bobp)
184       (delete-region (point-min) (point)))
185     (mm-with-unibyte-current-buffer
186       (with-temp-buffer
187         (flet ((gpg-encrypt-func
188                 (sign plaintext ciphertext result recipients &optional
189                       passphrase sign-with-key armor textmode)
190                 (if sign
191                     (gpg-sign-encrypt
192                      plaintext ciphertext result recipients passphrase
193                      sign-with-key armor textmode)
194                   (gpg-encrypt
195                    plaintext ciphertext result recipients passphrase
196                    armor textmode))))
197           (unless (gpg-encrypt-func
198                    sign
199                    text (setq cipher (current-buffer))
200                    result-buffer
201                    (split-string
202                     (or
203                      (message-options-get 'message-recipients)
204                      (message-options-set 'message-recipients
205                                           (read-string "Recipients: ")))
206                     "[ \f\t\n\r\v,]+")
207                    nil
208                    (message-options-get 'message-sender)
209                    t t) ; armor & textmode
210             (unless (> (point-max) (point-min))
211               (pop-to-buffer result-buffer)
212               (error "Encrypt error"))))
213         (goto-char (point-min))
214         (while (re-search-forward "\r+$" nil t)
215           (replace-match "" t t))
216         (set-buffer text)
217         (delete-region (point-min) (point-max))
218         ;;(insert "Content-Type: application/pgp-encrypted\n\n")
219         ;;(insert "Version: 1\n\n")
220         (insert "\n")
221         (insert-buffer-substring cipher)
222         (goto-char (point-max))))))
223
224 ;; pgg wrapper
225
226 (eval-when-compile
227   (defvar pgg-default-user-id)
228   (defvar pgg-errors-buffer)
229   (defvar pgg-output-buffer))
230
231 (defun mml1991-pgg-sign (cont)
232   (let ((pgg-text-mode t)
233         (pgg-default-user-id (or (message-options-get 'mml-sender)
234                                  pgg-default-user-id))
235         headers cte)
236     ;; Don't sign headers.
237     (goto-char (point-min))
238     (when (re-search-forward "^$" nil t)
239       (setq headers (buffer-substring (point-min) (point)))
240       (save-restriction
241         (narrow-to-region (point-min) (point))
242         (setq cte (mail-fetch-field "content-transfer-encoding")))
243       (forward-line 1)
244       (delete-region (point-min) (point))
245       (when cte
246         (setq cte (intern (downcase cte)))
247         (mm-decode-content-transfer-encoding cte)))
248     (unless (pgg-sign-region (point-min) (point-max) t)
249       (pop-to-buffer pgg-errors-buffer)
250       (error "Encrypt error"))
251     (delete-region (point-min) (point-max))
252     (mm-with-unibyte-current-buffer
253       (insert-buffer-substring pgg-output-buffer)
254       (goto-char (point-min))
255       (while (re-search-forward "\r+$" nil t)
256         (replace-match "" t t))
257       (when cte
258         (mm-encode-content-transfer-encoding cte))
259       (goto-char (point-min))
260       (when headers
261         (insert headers))
262       (insert "\n"))
263     t))
264
265 (defun mml1991-pgg-encrypt (cont &optional sign)
266   (goto-char (point-min))
267   (when (re-search-forward "^$" nil t)
268     (let ((cte (save-restriction
269                  (narrow-to-region (point-min) (point))
270                  (mail-fetch-field "content-transfer-encoding"))))
271       ;; Strip MIME headers since it will be ASCII armoured.
272       (forward-line 1)
273       (delete-region (point-min) (point))
274       (when cte
275         (mm-decode-content-transfer-encoding (intern (downcase cte))))))
276   (unless (let ((pgg-text-mode t))
277             (pgg-encrypt-region
278              (point-min) (point-max)
279              (split-string
280               (or
281                (message-options-get 'message-recipients)
282                (message-options-set 'message-recipients
283                                     (read-string "Recipients: ")))
284               "[ \f\t\n\r\v,]+")
285              sign))
286     (pop-to-buffer pgg-errors-buffer)
287     (error "Encrypt error"))
288   (delete-region (point-min) (point-max))
289   (insert "\n")
290   (insert-buffer-substring pgg-output-buffer)
291   t)
292
293 ;;;###autoload
294 (defun mml1991-encrypt (cont &optional sign)
295   (let ((func (nth 2 (assq mml1991-use mml1991-function-alist))))
296     (if func
297         (funcall func cont sign)
298       (error "Cannot find encrypt function"))))
299
300 ;;;###autoload
301 (defun mml1991-sign (cont)
302   (let ((func (nth 1 (assq mml1991-use mml1991-function-alist))))
303     (if func
304         (funcall func cont)
305       (error "Cannot find sign function"))))
306
307 (provide 'mml1991)
308
309 ;; Local Variables:
310 ;; coding: iso-8859-1
311 ;; End:
312
313 ;;; arch-tag: e542be18-ab28-4393-9b33-97fe9cf30706
314 ;;; mml1991.el ends here