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