Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; mm-uu.el --- Return uu stuff as mm handles |
e84b4b86 TTN |
2 | |
3 | ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, | |
114f9c96 | 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
c113de23 GM |
5 | |
6 | ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> | |
23f87bed | 7 | ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp |
c113de23 GM |
8 | |
9 | ;; This file is part of GNU Emacs. | |
10 | ||
5e809f55 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
c113de23 | 12 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
15 | ||
c113de23 GM |
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 | |
5e809f55 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
c113de23 GM |
23 | |
24 | ;;; Commentary: | |
25 | ||
c113de23 GM |
26 | ;;; Code: |
27 | ||
28 | (eval-when-compile (require 'cl)) | |
29 | (require 'mail-parse) | |
30 | (require 'nnheader) | |
31 | (require 'mm-decode) | |
32 | (require 'mailcap) | |
23f87bed | 33 | (require 'mml2015) |
c113de23 | 34 | |
23f87bed MB |
35 | (autoload 'uudecode-decode-region "uudecode") |
36 | (autoload 'uudecode-decode-region-external "uudecode") | |
37 | (autoload 'uudecode-decode-region-internal "uudecode") | |
c113de23 | 38 | |
23f87bed MB |
39 | (autoload 'binhex-decode-region "binhex") |
40 | (autoload 'binhex-decode-region-external "binhex") | |
41 | (autoload 'binhex-decode-region-internal "binhex") | |
c113de23 | 42 | |
23f87bed MB |
43 | (autoload 'yenc-decode-region "yenc") |
44 | (autoload 'yenc-extract-filename "yenc") | |
c113de23 GM |
45 | |
46 | (defcustom mm-uu-decode-function 'uudecode-decode-region | |
47 | "*Function to uudecode. | |
944c69bf DL |
48 | Internal function is done in Lisp by default, therefore decoding may |
49 | appear to be horribly slow. You can make Gnus use an external | |
c113de23 | 50 | decoder, such as uudecode." |
944c69bf | 51 | :type '(choice |
23f87bed MB |
52 | (function-item :tag "Auto detect" uudecode-decode-region) |
53 | (function-item :tag "Internal" uudecode-decode-region-internal) | |
944c69bf | 54 | (function-item :tag "External" uudecode-decode-region-external)) |
44d5f576 | 55 | :group 'gnus-article-mime) |
c113de23 | 56 | |
c113de23 GM |
57 | (defcustom mm-uu-binhex-decode-function 'binhex-decode-region |
58 | "*Function to binhex decode. | |
23f87bed MB |
59 | Internal function is done in elisp by default, therefore decoding may |
60 | appear to be horribly slow . You can make Gnus use the external Unix | |
c113de23 | 61 | decoder, such as hexbin." |
23f87bed MB |
62 | :type '(choice (function-item :tag "Auto detect" binhex-decode-region) |
63 | (function-item :tag "Internal" binhex-decode-region-internal) | |
64 | (function-item :tag "External" binhex-decode-region-external)) | |
44d5f576 | 65 | :group 'gnus-article-mime) |
c113de23 | 66 | |
23f87bed | 67 | (defvar mm-uu-yenc-decode-function 'yenc-decode-region) |
c113de23 | 68 | |
23f87bed | 69 | (defvar mm-uu-beginning-regexp nil) |
c113de23 GM |
70 | |
71 | (defvar mm-dissect-disposition "inline" | |
72 | "The default disposition of uu parts. | |
73 | This can be either \"inline\" or \"attachment\".") | |
74 | ||
53cfefc8 MB |
75 | (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources" |
76 | "The regexp of Emacs sources groups." | |
77 | :version "22.1" | |
78 | :type 'regexp | |
79 | :group 'gnus-article-mime) | |
23f87bed | 80 | |
53cfefc8 MB |
81 | (defcustom mm-uu-diff-groups-regexp |
82 | "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)" | |
83 | "Regexp matching diff groups." | |
bf247b6e | 84 | :version "22.1" |
23f87bed MB |
85 | :type 'regexp |
86 | :group 'gnus-article-mime) | |
87 | ||
01c52d31 MB |
88 | (defcustom mm-uu-tex-groups-regexp "\\.tex\\>" |
89 | "*Regexp matching TeX groups." | |
330f707b | 90 | :version "23.1" |
01c52d31 MB |
91 | :type 'regexp |
92 | :group 'gnus-article-mime) | |
93 | ||
23f87bed MB |
94 | (defvar mm-uu-type-alist |
95 | '((postscript | |
96 | "^%!PS-" | |
97 | "^%%EOF$" | |
98 | mm-uu-postscript-extract | |
99 | nil) | |
01c52d31 | 100 | (uu ;; Maybe we should have a more strict test here. |
23f87bed MB |
101 | "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+" |
102 | "^end[ \t]*$" | |
103 | mm-uu-uu-extract | |
104 | mm-uu-uu-filename) | |
105 | (binhex | |
01c52d31 | 106 | "^:.\\{63,63\\}$" |
23f87bed MB |
107 | ":$" |
108 | mm-uu-binhex-extract | |
109 | nil | |
110 | mm-uu-binhex-filename) | |
111 | (yenc | |
112 | "^=ybegin.*size=[0-9]+.*name=.*$" | |
113 | "^=yend.*size=[0-9]+" | |
114 | mm-uu-yenc-extract | |
115 | mm-uu-yenc-filename) | |
116 | (shar | |
117 | "^#! */bin/sh" | |
118 | "^exit 0$" | |
119 | mm-uu-shar-extract) | |
120 | (forward | |
7573397b SM |
121 | ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and |
122 | ;; Peter von der Ah\'e <pahe@daimi.au.dk> | |
23f87bed MB |
123 | "^-+ \\(Start of \\)?Forwarded message" |
124 | "^-+ End \\(of \\)?forwarded message" | |
125 | mm-uu-forward-extract | |
126 | nil | |
127 | mm-uu-forward-test) | |
128 | (gnatsweb | |
129 | "^----gnatsweb-attachment----" | |
130 | nil | |
131 | mm-uu-gnatsweb-extract) | |
132 | (pgp-signed | |
133 | "^-----BEGIN PGP SIGNED MESSAGE-----" | |
134 | "^-----END PGP SIGNATURE-----" | |
135 | mm-uu-pgp-signed-extract | |
136 | nil | |
137 | nil) | |
138 | (pgp-encrypted | |
139 | "^-----BEGIN PGP MESSAGE-----" | |
140 | "^-----END PGP MESSAGE-----" | |
141 | mm-uu-pgp-encrypted-extract | |
142 | nil | |
143 | nil) | |
144 | (pgp-key | |
145 | "^-----BEGIN PGP PUBLIC KEY BLOCK-----" | |
146 | "^-----END PGP PUBLIC KEY BLOCK-----" | |
147 | mm-uu-pgp-key-extract | |
148 | mm-uu-gpg-key-skip-to-last | |
149 | nil) | |
150 | (emacs-sources | |
151 | "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--" | |
152 | "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here" | |
153 | mm-uu-emacs-sources-extract | |
154 | nil | |
155 | mm-uu-emacs-sources-test) | |
156 | (diff | |
157 | "^Index: " | |
158 | nil | |
159 | mm-uu-diff-extract | |
160 | nil | |
01c52d31 MB |
161 | mm-uu-diff-test) |
162 | (message-marks | |
163 | ;; Text enclosed with tags similar to `message-mark-insert-begin' and | |
164 | ;; `message-mark-insert-end'. Don't use those variables to avoid | |
165 | ;; dependency on `message.el'. | |
166 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" | |
167 | "^-+[8<>]*-\\{9,\\}[a-z ]+-\\{9,\\}[a-z ]+-\\{9,\\}[8<>]*-+$" | |
14e8de0c | 168 | (lambda () (mm-uu-verbatim-marks-extract -1 0 1 -1)) |
01c52d31 MB |
169 | nil) |
170 | ;; Omitting [a-z8<] leads to false positives (bogus signature separators | |
171 | ;; and mailing list banners). | |
172 | (insert-marks | |
173 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" | |
174 | "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$" | |
175 | (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1)) | |
176 | nil) | |
177 | (verbatim-marks | |
178 | ;; slrn-style verbatim marks, see | |
179 | ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81 | |
180 | "^#v\\+" | |
181 | "^#v\\-$" | |
182 | (lambda () (mm-uu-verbatim-marks-extract 0 0)) | |
183 | nil) | |
184 | (LaTeX | |
185 | "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" | |
186 | "^\\\\end{document}" | |
187 | mm-uu-latex-extract | |
188 | nil | |
189 | mm-uu-latex-test)) | |
53cfefc8 MB |
190 | "A list of specifications for non-MIME attachments. |
191 | Each element consist of the following entries: label, | |
192 | start-regexp, end-regexp, extract-function, test-function. | |
193 | ||
f931ce84 MB |
194 | After modifying this list you must run \\[mm-uu-configure]. |
195 | ||
196 | You can disable elements from this list by customizing | |
197 | `mm-uu-configure-list'.") | |
23f87bed MB |
198 | |
199 | (defcustom mm-uu-configure-list '((shar . disabled)) | |
200 | "A list of mm-uu configuration. | |
201 | To disable dissecting shar codes, for instance, add | |
202 | `(shar . disabled)' to this list." | |
203 | :type 'alist | |
204 | :options (mapcar (lambda (entry) | |
205 | (list (car entry) '(const disabled))) | |
206 | mm-uu-type-alist) | |
207 | :group 'gnus-article-mime) | |
208 | ||
73043f7d MB |
209 | (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded)) |
210 | "MIME type and parameters for text/plain parts. | |
211 | `gnus-decoded' is a fake charset, which means no further decoding.") | |
212 | ||
23f87bed MB |
213 | ;; functions |
214 | ||
215 | (defsubst mm-uu-type (entry) | |
216 | (car entry)) | |
217 | ||
218 | (defsubst mm-uu-beginning-regexp (entry) | |
219 | (nth 1 entry)) | |
220 | ||
221 | (defsubst mm-uu-end-regexp (entry) | |
222 | (nth 2 entry)) | |
223 | ||
224 | (defsubst mm-uu-function-extract (entry) | |
225 | (nth 3 entry)) | |
226 | ||
227 | (defsubst mm-uu-function-1 (entry) | |
228 | (nth 4 entry)) | |
229 | ||
230 | (defsubst mm-uu-function-2 (entry) | |
231 | (nth 5 entry)) | |
232 | ||
01c52d31 MB |
233 | ;; In Emacs 22, we could use `min-colors' in the face definition. But Emacs |
234 | ;; 21 and XEmacs don't support it. | |
235 | (defcustom mm-uu-hide-markers | |
236 | (< 16 (or (and (fboundp 'defined-colors) | |
237 | (length (defined-colors))) | |
238 | (and (fboundp 'device-color-cells) | |
239 | (device-color-cells)) | |
240 | 0)) | |
241 | "If non-nil, hide verbatim markers. | |
242 | The value should be nil on displays where the face | |
243 | `mm-uu-extract' isn't distinguishable to the face `default'." | |
244 | :type '(choice (const :tag "Hide" t) | |
245 | (const :tag "Don't hide" nil)) | |
330f707b | 246 | :version "23.1" ;; No Gnus |
01c52d31 MB |
247 | :group 'gnus-article-mime) |
248 | ||
14e8de0c MB |
249 | (defface mm-uu-extract '(;; Inspired by `gnus-cite-3' |
250 | (((type tty) | |
251 | (class color) | |
252 | (background dark)) | |
253 | (:background "dark blue")) | |
01c52d31 MB |
254 | (((class color) |
255 | (background dark)) | |
256 | (:foreground "light yellow" | |
257 | :background "dark green")) | |
14e8de0c MB |
258 | (((type tty) |
259 | (class color) | |
260 | (background light)) | |
261 | (:foreground "dark blue")) | |
01c52d31 MB |
262 | (((class color) |
263 | (background light)) | |
264 | (:foreground "dark green" | |
265 | :background "light yellow")) | |
266 | (t | |
267 | ())) | |
268 | "Face for extracted buffers." | |
269 | ;; See `mm-uu-verbatim-marks-extract'. | |
330f707b | 270 | :version "23.1" ;; No Gnus |
01c52d31 MB |
271 | :group 'gnus-article-mime) |
272 | ||
273 | (defun mm-uu-copy-to-buffer (&optional from to properties) | |
23f87bed | 274 | "Copy the contents of the current buffer to a fresh buffer. |
01c52d31 MB |
275 | Return that buffer. |
276 | ||
277 | If PROPERTIES is non-nil, PROPERTIES are applied to the buffer, | |
278 | see `set-text-properties'. If PROPERTIES equals t, this means to | |
279 | apply the face `mm-uu-extract'." | |
7573397b | 280 | (let ((obuf (current-buffer)) |
456cace2 SM |
281 | (multi (and (boundp 'enable-multibyte-characters) |
282 | enable-multibyte-characters)) | |
b890d447 | 283 | (coding-system |
7573397b SM |
284 | ;; Might not exist in non-MULE XEmacs |
285 | (when (boundp 'buffer-file-coding-system) | |
286 | buffer-file-coding-system))) | |
287 | (with-current-buffer (generate-new-buffer " *mm-uu*") | |
456cace2 | 288 | (if multi (mm-enable-multibyte) (mm-disable-multibyte)) |
23f87bed MB |
289 | (setq buffer-file-coding-system coding-system) |
290 | (insert-buffer-substring obuf from to) | |
01c52d31 MB |
291 | (cond ((eq properties t) |
292 | (set-text-properties (point-min) (point-max) | |
293 | '(face mm-uu-extract))) | |
294 | (properties | |
295 | (set-text-properties (point-min) (point-max) properties))) | |
23f87bed MB |
296 | (current-buffer)))) |
297 | ||
c113de23 GM |
298 | (defun mm-uu-configure-p (key val) |
299 | (member (cons key val) mm-uu-configure-list)) | |
300 | ||
301 | (defun mm-uu-configure (&optional symbol value) | |
53cfefc8 MB |
302 | "Configure detection of non-MIME attachments." |
303 | (interactive) | |
c113de23 | 304 | (if symbol (set-default symbol value)) |
23f87bed MB |
305 | (setq mm-uu-beginning-regexp nil) |
306 | (mapcar (lambda (entry) | |
307 | (if (mm-uu-configure-p (mm-uu-type entry) 'disabled) | |
308 | nil | |
309 | (setq mm-uu-beginning-regexp | |
310 | (concat mm-uu-beginning-regexp | |
311 | (if mm-uu-beginning-regexp "\\|") | |
312 | (mm-uu-beginning-regexp entry))))) | |
313 | mm-uu-type-alist)) | |
2ec4d9ab | 314 | |
c113de23 GM |
315 | (mm-uu-configure) |
316 | ||
9efa445f DN |
317 | (defvar file-name) |
318 | (defvar start-point) | |
319 | (defvar end-point) | |
320 | (defvar entry) | |
23f87bed MB |
321 | |
322 | (defun mm-uu-uu-filename () | |
323 | (if (looking-at ".+") | |
324 | (setq file-name | |
325 | (let ((nnheader-file-name-translation-alist | |
326 | '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) | |
327 | (nnheader-translate-file-chars (match-string 0)))))) | |
328 | ||
329 | (defun mm-uu-binhex-filename () | |
330 | (setq file-name | |
331 | (ignore-errors | |
332 | (binhex-decode-region start-point end-point t)))) | |
333 | ||
334 | (defun mm-uu-yenc-filename () | |
335 | (goto-char start-point) | |
336 | (setq file-name | |
337 | (ignore-errors | |
338 | (yenc-extract-filename)))) | |
339 | ||
340 | (defun mm-uu-forward-test () | |
341 | (save-excursion | |
342 | (goto-char start-point) | |
343 | (forward-line) | |
344 | (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) | |
345 | ||
346 | (defun mm-uu-postscript-extract () | |
347 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
348 | '("application/postscript"))) | |
349 | ||
01c52d31 MB |
350 | (defun mm-uu-verbatim-marks-extract (start-offset end-offset |
351 | &optional | |
352 | start-hide | |
353 | end-hide) | |
354 | (let ((start (or (and mm-uu-hide-markers | |
355 | start-hide) | |
356 | start-offset | |
357 | 1)) | |
358 | (end (or (and mm-uu-hide-markers | |
359 | end-hide) | |
360 | end-offset | |
361 | -1))) | |
362 | (mm-make-handle | |
363 | (mm-uu-copy-to-buffer | |
364 | (progn (goto-char start-point) | |
365 | (forward-line start) | |
366 | (point)) | |
367 | (progn (goto-char end-point) | |
368 | (forward-line end) | |
369 | (point)) | |
370 | t) | |
371 | '("text/x-verbatim" (charset . gnus-decoded))))) | |
372 | ||
373 | (defun mm-uu-latex-extract () | |
374 | (mm-make-handle | |
375 | (mm-uu-copy-to-buffer start-point end-point t) | |
376 | ;; application/x-tex? | |
377 | '("text/x-verbatim" (charset . gnus-decoded)))) | |
378 | ||
23f87bed MB |
379 | (defun mm-uu-emacs-sources-extract () |
380 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
46e8fe3d | 381 | '("application/emacs-lisp" (charset . gnus-decoded)) |
23f87bed MB |
382 | nil nil |
383 | (list mm-dissect-disposition | |
384 | (cons 'filename file-name)))) | |
385 | ||
9efa445f | 386 | (defvar gnus-newsgroup-name) |
23f87bed MB |
387 | |
388 | (defun mm-uu-emacs-sources-test () | |
389 | (setq file-name (match-string 1)) | |
390 | (and gnus-newsgroup-name | |
391 | mm-uu-emacs-sources-regexp | |
392 | (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name))) | |
393 | ||
394 | (defun mm-uu-diff-extract () | |
395 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
46e8fe3d | 396 | '("text/x-patch" (charset . gnus-decoded)))) |
23f87bed MB |
397 | |
398 | (defun mm-uu-diff-test () | |
399 | (and gnus-newsgroup-name | |
400 | mm-uu-diff-groups-regexp | |
401 | (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name))) | |
402 | ||
01c52d31 MB |
403 | (defun mm-uu-latex-test () |
404 | (and gnus-newsgroup-name | |
405 | mm-uu-tex-groups-regexp | |
406 | (string-match mm-uu-tex-groups-regexp gnus-newsgroup-name))) | |
407 | ||
23f87bed MB |
408 | (defun mm-uu-forward-extract () |
409 | (mm-make-handle (mm-uu-copy-to-buffer | |
410 | (progn (goto-char start-point) (forward-line) (point)) | |
411 | (progn (goto-char end-point) (forward-line -1) (point))) | |
412 | '("message/rfc822" (charset . gnus-decoded)))) | |
413 | ||
414 | (defun mm-uu-uu-extract () | |
415 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
416 | (list (or (and file-name | |
417 | (string-match "\\.[^\\.]+$" | |
418 | file-name) | |
419 | (mailcap-extension-to-mime | |
420 | (match-string 0 file-name))) | |
421 | "application/octet-stream")) | |
422 | 'x-uuencode nil | |
423 | (if (and file-name (not (equal file-name ""))) | |
424 | (list mm-dissect-disposition | |
425 | (cons 'filename file-name))))) | |
426 | ||
427 | (defun mm-uu-binhex-extract () | |
428 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
429 | (list (or (and file-name | |
430 | (string-match "\\.[^\\.]+$" file-name) | |
431 | (mailcap-extension-to-mime | |
432 | (match-string 0 file-name))) | |
433 | "application/octet-stream")) | |
434 | 'x-binhex nil | |
435 | (if (and file-name (not (equal file-name ""))) | |
436 | (list mm-dissect-disposition | |
437 | (cons 'filename file-name))))) | |
438 | ||
5f3c7783 GM |
439 | (defvar gnus-original-article-buffer) ; gnus.el |
440 | ||
23f87bed | 441 | (defun mm-uu-yenc-extract () |
b890d447 MB |
442 | ;; This might not be exactly correct, but we sure can't get the |
443 | ;; binary data from the article buffer, since that's already in a | |
444 | ;; non-binary charset. So get it from the original article buffer. | |
456cace2 | 445 | (mm-make-handle (with-current-buffer gnus-original-article-buffer |
b890d447 | 446 | (mm-uu-copy-to-buffer start-point end-point)) |
23f87bed MB |
447 | (list (or (and file-name |
448 | (string-match "\\.[^\\.]+$" file-name) | |
449 | (mailcap-extension-to-mime | |
450 | (match-string 0 file-name))) | |
451 | "application/octet-stream")) | |
452 | 'x-yenc nil | |
453 | (if (and file-name (not (equal file-name ""))) | |
454 | (list mm-dissect-disposition | |
455 | (cons 'filename file-name))))) | |
456 | ||
457 | ||
458 | (defun mm-uu-shar-extract () | |
459 | (mm-make-handle (mm-uu-copy-to-buffer start-point end-point) | |
460 | '("application/x-shar"))) | |
461 | ||
462 | (defun mm-uu-gnatsweb-extract () | |
463 | (save-restriction | |
464 | (goto-char start-point) | |
465 | (forward-line) | |
466 | (narrow-to-region (point) end-point) | |
467 | (mm-dissect-buffer t))) | |
468 | ||
469 | (defun mm-uu-pgp-signed-test (&rest rest) | |
470 | (and | |
471 | mml2015-use | |
472 | (mml2015-clear-verify-function) | |
473 | (cond | |
474 | ((eq mm-verify-option 'never) nil) | |
475 | ((eq mm-verify-option 'always) t) | |
476 | ((eq mm-verify-option 'known) t) | |
0565caeb MB |
477 | (t (prog1 |
478 | (y-or-n-p "Verify pgp signed part? ") | |
479 | (message "")))))) | |
23f87bed | 480 | |
9efa445f | 481 | (defvar gnus-newsgroup-charset) |
23f87bed MB |
482 | |
483 | (defun mm-uu-pgp-signed-extract-1 (handles ctl) | |
484 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))) | |
485 | (with-current-buffer buf | |
486 | (if (mm-uu-pgp-signed-test) | |
487 | (progn | |
488 | (mml2015-clean-buffer) | |
489 | (let ((coding-system-for-write (or gnus-newsgroup-charset | |
01c52d31 MB |
490 | 'iso-8859-1)) |
491 | (coding-system-for-read (or gnus-newsgroup-charset | |
492 | 'iso-8859-1))) | |
23f87bed MB |
493 | (funcall (mml2015-clear-verify-function)))) |
494 | (when (and mml2015-use (null (mml2015-clear-verify-function))) | |
495 | (mm-set-handle-multipart-parameter | |
496 | mm-security-handle 'gnus-details | |
01c52d31 MB |
497 | (format "Clear verification not supported by `%s'.\n" mml2015-use))) |
498 | (mml2015-extract-cleartext-signature)) | |
499 | (list (mm-make-handle buf mm-uu-text-plain-type))))) | |
23f87bed MB |
500 | |
501 | (defun mm-uu-pgp-signed-extract () | |
502 | (let ((mm-security-handle (list (format "multipart/signed")))) | |
503 | (mm-set-handle-multipart-parameter | |
504 | mm-security-handle 'protocol "application/x-gnus-pgp-signature") | |
505 | (save-restriction | |
506 | (narrow-to-region start-point end-point) | |
507 | (add-text-properties 0 (length (car mm-security-handle)) | |
508 | (list 'buffer (mm-uu-copy-to-buffer)) | |
509 | (car mm-security-handle)) | |
510 | (setcdr mm-security-handle | |
511 | (mm-uu-pgp-signed-extract-1 nil | |
512 | mm-security-handle))) | |
513 | mm-security-handle)) | |
514 | ||
515 | (defun mm-uu-pgp-encrypted-test (&rest rest) | |
516 | (and | |
517 | mml2015-use | |
518 | (mml2015-clear-decrypt-function) | |
519 | (cond | |
520 | ((eq mm-decrypt-option 'never) nil) | |
521 | ((eq mm-decrypt-option 'always) t) | |
522 | ((eq mm-decrypt-option 'known) t) | |
0565caeb MB |
523 | (t (prog1 |
524 | (y-or-n-p "Decrypt pgp encrypted part? ") | |
525 | (message "")))))) | |
23f87bed MB |
526 | |
527 | (defun mm-uu-pgp-encrypted-extract-1 (handles ctl) | |
0565caeb MB |
528 | (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))) |
529 | (first t) | |
530 | charset) | |
531 | ;; Make sure there's a blank line between header and body. | |
532 | (with-current-buffer buf | |
533 | (goto-char (point-min)) | |
534 | (while (prog2 | |
535 | (forward-line 1) | |
536 | (if first | |
537 | (looking-at "[^\t\n ]+:") | |
538 | (looking-at "[^\t\n ]+:\\|[\t ]")) | |
539 | (setq first nil))) | |
540 | (unless (memq (char-after) '(?\n nil)) | |
541 | (insert "\n")) | |
542 | (save-restriction | |
543 | (narrow-to-region (point-min) (point)) | |
544 | (setq charset (mail-fetch-field "charset"))) | |
545 | (if (and (mm-uu-pgp-encrypted-test) | |
546 | (progn | |
547 | (mml2015-clean-buffer) | |
548 | (funcall (mml2015-clear-decrypt-function)) | |
549 | (equal (mm-handle-multipart-ctl-parameter mm-security-handle | |
550 | 'gnus-info) | |
551 | "OK"))) | |
552 | (progn | |
553 | ;; Decode charset. | |
9606f1cb MB |
554 | (if (and (or charset |
555 | (setq charset gnus-newsgroup-charset)) | |
556 | (setq charset (mm-charset-to-coding-system charset)) | |
557 | (not (eq charset 'ascii))) | |
558 | ;; Assume that buffer's multibyteness is turned off. | |
559 | ;; See `mml2015-pgg-clear-decrypt'. | |
560 | (insert (mm-decode-coding-string (prog1 | |
561 | (buffer-string) | |
562 | (erase-buffer) | |
563 | (mm-enable-multibyte)) | |
564 | charset)) | |
565 | (mm-enable-multibyte)) | |
0565caeb MB |
566 | (list (mm-make-handle buf mm-uu-text-plain-type))) |
567 | (list (mm-make-handle buf '("application/pgp-encrypted"))))))) | |
23f87bed MB |
568 | |
569 | (defun mm-uu-pgp-encrypted-extract () | |
570 | (let ((mm-security-handle (list (format "multipart/encrypted")))) | |
571 | (mm-set-handle-multipart-parameter | |
572 | mm-security-handle 'protocol "application/x-gnus-pgp-encrypted") | |
573 | (save-restriction | |
574 | (narrow-to-region start-point end-point) | |
575 | (add-text-properties 0 (length (car mm-security-handle)) | |
576 | (list 'buffer (mm-uu-copy-to-buffer)) | |
577 | (car mm-security-handle)) | |
578 | (setcdr mm-security-handle | |
579 | (mm-uu-pgp-encrypted-extract-1 nil | |
580 | mm-security-handle))) | |
581 | mm-security-handle)) | |
582 | ||
583 | (defun mm-uu-gpg-key-skip-to-last () | |
584 | (let ((point (point)) | |
585 | (end-regexp (mm-uu-end-regexp entry)) | |
586 | (beginning-regexp (mm-uu-beginning-regexp entry))) | |
587 | (when (and end-regexp | |
588 | (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))) | |
589 | (while (re-search-forward end-regexp nil t) | |
590 | (skip-chars-forward " \t\n\r") | |
591 | (if (looking-at beginning-regexp) | |
592 | (setq point (match-end 0))))) | |
593 | (goto-char point))) | |
594 | ||
595 | (defun mm-uu-pgp-key-extract () | |
596 | (let ((buf (mm-uu-copy-to-buffer start-point end-point))) | |
597 | (mm-make-handle buf | |
598 | '("application/pgp-keys")))) | |
599 | ||
9b64fb1f | 600 | ;;;###autoload |
73043f7d MB |
601 | (defun mm-uu-dissect (&optional noheader mime-type) |
602 | "Dissect the current buffer and return a list of uu handles. | |
603 | The optional NOHEADER means there's no header in the buffer. | |
604 | MIME-TYPE specifies a MIME type and parameters, which defaults to the | |
605 | value of `mm-uu-text-plain-type'." | |
23f87bed | 606 | (let ((case-fold-search t) |
73043f7d MB |
607 | (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type)) |
608 | text-start start-point end-point file-name result entry func) | |
c113de23 | 609 | (save-excursion |
23f87bed MB |
610 | (goto-char (point-min)) |
611 | (cond | |
73043f7d | 612 | (noheader) |
23f87bed MB |
613 | ((looking-at "\n") |
614 | (forward-line)) | |
615 | ((search-forward "\n\n" nil t) | |
616 | t) | |
617 | (t (goto-char (point-max)))) | |
73043f7d | 618 | (setq text-start (point)) |
23f87bed | 619 | (while (re-search-forward mm-uu-beginning-regexp nil t) |
531bedc3 MB |
620 | (setq start-point (match-beginning 0) |
621 | entry nil) | |
23f87bed MB |
622 | (let ((alist mm-uu-type-alist) |
623 | (beginning-regexp (match-string 0))) | |
624 | (while (not entry) | |
625 | (if (string-match (mm-uu-beginning-regexp (car alist)) | |
626 | beginning-regexp) | |
627 | (setq entry (car alist)) | |
628 | (pop alist)))) | |
629 | (if (setq func (mm-uu-function-1 entry)) | |
630 | (funcall func)) | |
c113de23 | 631 | (forward-line);; in case of failure |
23f87bed MB |
632 | (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)) |
633 | (let ((end-regexp (mm-uu-end-regexp entry))) | |
634 | (if (not end-regexp) | |
635 | (or (setq end-point (point-max)) t) | |
636 | (prog1 | |
637 | (re-search-forward end-regexp nil t) | |
638 | (forward-line) | |
639 | (setq end-point (point))))) | |
640 | (or (not (setq func (mm-uu-function-2 entry))) | |
641 | (funcall func))) | |
642 | (if (and (> start-point text-start) | |
643 | (progn | |
644 | (goto-char text-start) | |
645 | (re-search-forward "." start-point t))) | |
646 | (push | |
647 | (mm-make-handle (mm-uu-copy-to-buffer text-start start-point) | |
73043f7d | 648 | mm-uu-text-plain-type) |
23f87bed MB |
649 | result)) |
650 | (push | |
651 | (funcall (mm-uu-function-extract entry)) | |
652 | result) | |
653 | (goto-char (setq text-start end-point)))) | |
c113de23 | 654 | (when result |
23f87bed MB |
655 | (if (and (> (point-max) (1+ text-start)) |
656 | (save-excursion | |
657 | (goto-char text-start) | |
658 | (re-search-forward "." nil t))) | |
c113de23 GM |
659 | (push |
660 | (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) | |
73043f7d | 661 | mm-uu-text-plain-type) |
c113de23 GM |
662 | result)) |
663 | (setq result (cons "multipart/mixed" (nreverse result)))) | |
664 | result))) | |
665 | ||
46e8fe3d MB |
666 | ;;;###autoload |
667 | (defun mm-uu-dissect-text-parts (handle &optional decoded) | |
668 | "Dissect text parts and put uu handles into HANDLE. | |
669 | Assume text has been decoded if DECODED is non-nil." | |
7347faa8 | 670 | (let ((buffer (mm-handle-buffer handle))) |
73043f7d MB |
671 | (cond ((stringp buffer) |
672 | (dolist (elem (cdr handle)) | |
46e8fe3d | 673 | (mm-uu-dissect-text-parts elem decoded))) |
73043f7d | 674 | ((bufferp buffer) |
7347faa8 MB |
675 | (let ((type (mm-handle-media-type handle)) |
676 | (case-fold-search t) ;; string-match | |
46e8fe3d | 677 | children charset encoding) |
7347faa8 MB |
678 | (when (and |
679 | (stringp type) | |
680 | ;; Mutt still uses application/pgp even though | |
681 | ;; it has already been withdrawn. | |
682 | (string-match "\\`text/\\|\\`application/pgp\\'" type) | |
46e8fe3d MB |
683 | (setq |
684 | children | |
685 | (with-current-buffer buffer | |
686 | (cond | |
687 | ((or decoded | |
688 | (eq (setq charset (mail-content-type-get | |
689 | (mm-handle-type handle) | |
690 | 'charset)) | |
691 | 'gnus-decoded)) | |
692 | (setq decoded t) | |
693 | (mm-uu-dissect | |
694 | t (cons type '((charset . gnus-decoded))))) | |
695 | (charset | |
696 | (setq decoded t) | |
697 | (mm-with-multibyte-buffer | |
698 | (insert (mm-decode-string (mm-get-part handle) | |
699 | charset)) | |
700 | (mm-uu-dissect | |
701 | t (cons type '((charset . gnus-decoded)))))) | |
702 | ((setq encoding (mm-handle-encoding handle)) | |
703 | (setq decoded nil) | |
704 | ;; Inherit the multibyteness of the `buffer'. | |
705 | (with-temp-buffer | |
706 | (insert-buffer-substring buffer) | |
707 | (mm-decode-content-transfer-encoding | |
708 | encoding type) | |
709 | (mm-uu-dissect t (list type)))) | |
710 | (t | |
711 | (setq decoded nil) | |
712 | (mm-uu-dissect t (list type))))))) | |
7347faa8 MB |
713 | ;; Ignore it if a given part is dissected into a single |
714 | ;; part of which the type is the same as the given one. | |
715 | (if (and (<= (length children) 2) | |
716 | (string-equal (mm-handle-media-type (cadr children)) | |
717 | type)) | |
718 | (kill-buffer (mm-handle-buffer (cadr children))) | |
719 | (kill-buffer buffer) | |
720 | (setcdr handle (cdr children)) | |
721 | (setcar handle (car children)) ;; "multipart/mixed" | |
722 | (dolist (elem (cdr children)) | |
46e8fe3d | 723 | (mm-uu-dissect-text-parts elem decoded)))))) |
73043f7d MB |
724 | (t |
725 | (dolist (elem handle) | |
46e8fe3d | 726 | (mm-uu-dissect-text-parts elem decoded)))))) |
73043f7d | 727 | |
c113de23 GM |
728 | (provide 'mm-uu) |
729 | ||
7573397b | 730 | ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c |
c113de23 | 731 | ;;; mm-uu.el ends here |