1 ;;; mm-uu.el --- Return uu stuff as mm handles
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
9 ;; This file is part of GNU Emacs.
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 3 of the License, or
14 ;; (at your option) any later version.
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.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 (eval-when-compile (require 'cl))
35 (autoload 'uudecode-decode-region "uudecode")
36 (autoload 'uudecode-decode-region-external "uudecode")
37 (autoload 'uudecode-decode-region-internal "uudecode")
39 (autoload 'binhex-decode-region "binhex")
40 (autoload 'binhex-decode-region-external "binhex")
41 (autoload 'binhex-decode-region-internal "binhex")
43 (autoload 'yenc-decode-region "yenc")
44 (autoload 'yenc-extract-filename "yenc")
46 (defcustom mm-uu-decode-function 'uudecode-decode-region
47 "*Function to uudecode.
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
50 decoder, such as uudecode."
52 (function-item :tag "Auto detect" uudecode-decode-region)
53 (function-item :tag "Internal" uudecode-decode-region-internal)
54 (function-item :tag "External" uudecode-decode-region-external))
55 :group 'gnus-article-mime)
57 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
58 "*Function to binhex decode.
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
61 decoder, such as hexbin."
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))
65 :group 'gnus-article-mime)
67 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
69 (defvar mm-uu-beginning-regexp nil)
71 (defvar mm-dissect-disposition "inline"
72 "The default disposition of uu parts.
73 This can be either \"inline\" or \"attachment\".")
75 (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources"
76 "The regexp of Emacs sources groups."
79 :group 'gnus-article-mime)
81 (defcustom mm-uu-diff-groups-regexp
82 "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)"
83 "Regexp matching diff groups."
86 :group 'gnus-article-mime)
88 (defcustom mm-uu-tex-groups-regexp "\\.tex\\>"
89 "*Regexp matching TeX groups."
92 :group 'gnus-article-mime)
94 (defvar mm-uu-type-alist
98 mm-uu-postscript-extract
100 (uu ;; Maybe we should have a more strict test here.
101 "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
110 mm-uu-binhex-filename)
112 "^=ybegin.*size=[0-9]+.*name=.*$"
113 "^=yend.*size=[0-9]+"
121 ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
122 ;; Peter von der Ah\'e <pahe@daimi.au.dk>
123 "^-+ \\(Start of \\)?Forwarded message"
124 "^-+ End \\(of \\)?forwarded message"
125 mm-uu-forward-extract
129 "^----gnatsweb-attachment----"
131 mm-uu-gnatsweb-extract)
133 "^-----BEGIN PGP SIGNED MESSAGE-----"
134 "^-----END PGP SIGNATURE-----"
135 mm-uu-pgp-signed-extract
139 "^-----BEGIN PGP MESSAGE-----"
140 "^-----END PGP MESSAGE-----"
141 mm-uu-pgp-encrypted-extract
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
151 "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
152 "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
153 mm-uu-emacs-sources-extract
155 mm-uu-emacs-sources-test)
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<>]*-+$"
168 (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1))
170 ;; Omitting [a-z8<] leads to false positives (bogus signature separators
171 ;; and mailing list banners).
173 "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$"
174 "^ *\\(-\\|_\\)\\{30,\\}.*[a-z8<].*\\(-\\|_\\)\\{30,\\} *$"
175 (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1))
178 ;; slrn-style verbatim marks, see
179 ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81
182 (lambda () (mm-uu-verbatim-marks-extract 0 0))
185 "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]"
193 mm-uu-org-src-code-block-extract)
195 "^[ \t]*#\\+[[:alpha:]]+: "
197 mm-uu-org-src-code-block-extract))
198 "A list of specifications for non-MIME attachments.
199 Each element consist of the following entries: label,
200 start-regexp, end-regexp, extract-function, test-function.
202 After modifying this list you must run \\[mm-uu-configure].
204 You can disable elements from this list by customizing
205 `mm-uu-configure-list'.")
207 (defcustom mm-uu-configure-list '((shar . disabled))
208 "A list of mm-uu configuration.
209 To disable dissecting shar codes, for instance, add
210 `(shar . disabled)' to this list."
212 :options (mapcar (lambda (entry)
213 (list (car entry) '(const disabled)))
215 :group 'gnus-article-mime)
217 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
218 "MIME type and parameters for text/plain parts.
219 `gnus-decoded' is a fake charset, which means no further decoding.")
223 (defsubst mm-uu-type (entry)
226 (defsubst mm-uu-beginning-regexp (entry)
229 (defsubst mm-uu-end-regexp (entry)
232 (defsubst mm-uu-function-extract (entry)
235 (defsubst mm-uu-function-1 (entry)
238 (defsubst mm-uu-function-2 (entry)
241 ;; In Emacs 22, we could use `min-colors' in the face definition. But Emacs
242 ;; 21 and XEmacs don't support it.
243 (defcustom mm-uu-hide-markers
244 (< 16 (or (and (fboundp 'defined-colors)
245 (length (defined-colors)))
246 (and (fboundp 'device-color-cells)
247 (device-color-cells))
249 "If non-nil, hide verbatim markers.
250 The value should be nil on displays where the face
251 `mm-uu-extract' isn't distinguishable to the face `default'."
252 :type '(choice (const :tag "Hide" t)
253 (const :tag "Don't hide" nil))
254 :version "23.1" ;; No Gnus
255 :group 'gnus-article-mime)
257 (defface mm-uu-extract '(;; Inspired by `gnus-cite-3'
261 (:background "dark blue"))
264 (:foreground "light yellow"
265 :background "dark green"))
269 (:foreground "dark blue"))
272 (:foreground "dark green"
273 :background "light yellow"))
276 "Face for extracted buffers."
277 ;; See `mm-uu-verbatim-marks-extract'.
278 :version "23.1" ;; No Gnus
279 :group 'gnus-article-mime)
281 (defun mm-uu-copy-to-buffer (&optional from to properties)
282 "Copy the contents of the current buffer to a fresh buffer.
285 If PROPERTIES is non-nil, PROPERTIES are applied to the buffer,
286 see `set-text-properties'. If PROPERTIES equals t, this means to
287 apply the face `mm-uu-extract'."
288 (let ((obuf (current-buffer))
289 (multi (and (boundp 'enable-multibyte-characters)
290 enable-multibyte-characters))
292 ;; Might not exist in non-MULE XEmacs
293 (when (boundp 'buffer-file-coding-system)
294 buffer-file-coding-system)))
295 (with-current-buffer (generate-new-buffer " *mm-uu*")
296 (if multi (mm-enable-multibyte) (mm-disable-multibyte))
297 (setq buffer-file-coding-system coding-system)
298 (insert-buffer-substring obuf from to)
299 (cond ((eq properties t)
300 (set-text-properties (point-min) (point-max)
301 '(face mm-uu-extract)))
303 (set-text-properties (point-min) (point-max) properties)))
306 (defun mm-uu-configure-p (key val)
307 (member (cons key val) mm-uu-configure-list))
309 (defun mm-uu-configure (&optional symbol value)
310 "Configure detection of non-MIME attachments."
312 (if symbol (set-default symbol value))
313 (setq mm-uu-beginning-regexp nil)
314 (mapcar (lambda (entry)
315 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
317 (setq mm-uu-beginning-regexp
318 (concat mm-uu-beginning-regexp
319 (if mm-uu-beginning-regexp "\\|")
320 (mm-uu-beginning-regexp entry)))))
330 (defun mm-uu-uu-filename ()
331 (if (looking-at ".+")
333 (let ((nnheader-file-name-translation-alist
334 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_))))
335 (nnheader-translate-file-chars (match-string 0))))))
337 (defun mm-uu-binhex-filename ()
340 (binhex-decode-region start-point end-point t))))
342 (defun mm-uu-yenc-filename ()
343 (goto-char start-point)
346 (yenc-extract-filename))))
348 (defun mm-uu-forward-test ()
350 (goto-char start-point)
352 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
354 (defun mm-uu-postscript-extract ()
355 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
356 '("application/postscript")))
358 (defun mm-uu-verbatim-marks-extract (start-offset end-offset
362 (let ((start (or (and mm-uu-hide-markers
366 (end (or (and mm-uu-hide-markers
371 (mm-uu-copy-to-buffer
372 (progn (goto-char start-point)
375 (progn (goto-char end-point)
379 '("text/x-verbatim" (charset . gnus-decoded)))))
381 (defun mm-uu-latex-extract ()
383 (mm-uu-copy-to-buffer start-point end-point t)
384 ;; application/x-tex?
385 '("text/x-verbatim" (charset . gnus-decoded))))
387 (defun mm-uu-emacs-sources-extract ()
388 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
389 '("application/emacs-lisp" (charset . gnus-decoded))
391 (list mm-dissect-disposition
392 (cons 'filename file-name))))
394 (defun mm-uu-org-src-code-block-extract ()
395 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
398 (defvar gnus-newsgroup-name)
400 (defun mm-uu-emacs-sources-test ()
401 (setq file-name (match-string 1))
402 (and gnus-newsgroup-name
403 mm-uu-emacs-sources-regexp
404 (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
406 (defun mm-uu-diff-extract ()
407 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
408 '("text/x-patch" (charset . gnus-decoded))))
410 (defun mm-uu-diff-test ()
411 (and gnus-newsgroup-name
412 mm-uu-diff-groups-regexp
413 (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
415 (defun mm-uu-latex-test ()
416 (and gnus-newsgroup-name
417 mm-uu-tex-groups-regexp
418 (string-match mm-uu-tex-groups-regexp gnus-newsgroup-name)))
420 (defun mm-uu-forward-extract ()
421 (mm-make-handle (mm-uu-copy-to-buffer
422 (progn (goto-char start-point) (forward-line) (point))
423 (progn (goto-char end-point) (forward-line -1) (point)))
424 '("message/rfc822" (charset . gnus-decoded))))
426 (defun mm-uu-uu-extract ()
427 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
428 (list (or (and file-name
429 (string-match "\\.[^\\.]+$"
431 (mailcap-extension-to-mime
432 (match-string 0 file-name)))
433 "application/octet-stream"))
435 (if (and file-name (not (equal file-name "")))
436 (list mm-dissect-disposition
437 (cons 'filename file-name)))))
439 (defun mm-uu-binhex-extract ()
440 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
441 (list (or (and file-name
442 (string-match "\\.[^\\.]+$" file-name)
443 (mailcap-extension-to-mime
444 (match-string 0 file-name)))
445 "application/octet-stream"))
447 (if (and file-name (not (equal file-name "")))
448 (list mm-dissect-disposition
449 (cons 'filename file-name)))))
451 (defvar gnus-original-article-buffer) ; gnus.el
453 (defun mm-uu-yenc-extract ()
454 ;; This might not be exactly correct, but we sure can't get the
455 ;; binary data from the article buffer, since that's already in a
456 ;; non-binary charset. So get it from the original article buffer.
457 (mm-make-handle (with-current-buffer gnus-original-article-buffer
458 (mm-uu-copy-to-buffer start-point end-point))
459 (list (or (and file-name
460 (string-match "\\.[^\\.]+$" file-name)
461 (mailcap-extension-to-mime
462 (match-string 0 file-name)))
463 "application/octet-stream"))
465 (if (and file-name (not (equal file-name "")))
466 (list mm-dissect-disposition
467 (cons 'filename file-name)))))
470 (defun mm-uu-shar-extract ()
471 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
472 '("application/x-shar")))
474 (defun mm-uu-gnatsweb-extract ()
476 (goto-char start-point)
478 (narrow-to-region (point) end-point)
479 (mm-dissect-buffer t)))
481 (defun mm-uu-pgp-signed-test (&rest rest)
484 (mml2015-clear-verify-function)
486 ((eq mm-verify-option 'never) nil)
487 ((eq mm-verify-option 'always) t)
488 ((eq mm-verify-option 'known) t)
490 (y-or-n-p "Verify pgp signed part? ")
493 (defvar gnus-newsgroup-charset)
495 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
496 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
497 (with-current-buffer buf
498 (if (mm-uu-pgp-signed-test)
500 (mml2015-clean-buffer)
501 (let ((coding-system-for-write (or buffer-file-coding-system
502 gnus-newsgroup-charset
504 (coding-system-for-read (or buffer-file-coding-system
505 gnus-newsgroup-charset
507 (funcall (mml2015-clear-verify-function))))
508 (when (and mml2015-use (null (mml2015-clear-verify-function)))
509 (mm-set-handle-multipart-parameter
510 mm-security-handle 'gnus-details
511 (format "Clear verification not supported by `%s'.\n" mml2015-use)))
512 (mml2015-extract-cleartext-signature))
513 (list (mm-make-handle buf mm-uu-text-plain-type)))))
515 (defun mm-uu-pgp-signed-extract ()
516 (let ((mm-security-handle (list (format "multipart/signed"))))
517 (mm-set-handle-multipart-parameter
518 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
520 (narrow-to-region start-point end-point)
521 (add-text-properties 0 (length (car mm-security-handle))
522 (list 'buffer (mm-uu-copy-to-buffer))
523 (car mm-security-handle))
524 (setcdr mm-security-handle
525 (mm-uu-pgp-signed-extract-1 nil
526 mm-security-handle)))
529 (defun mm-uu-pgp-encrypted-test (&rest rest)
532 (mml2015-clear-decrypt-function)
534 ((eq mm-decrypt-option 'never) nil)
535 ((eq mm-decrypt-option 'always) t)
536 ((eq mm-decrypt-option 'known) t)
538 (y-or-n-p "Decrypt pgp encrypted part? ")
541 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
542 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
545 ;; Make sure there's a blank line between header and body.
546 (with-current-buffer buf
547 (goto-char (point-min))
551 (looking-at "[^\t\n ]+:")
552 (looking-at "[^\t\n ]+:\\|[\t ]"))
554 (unless (memq (char-after) '(?\n nil))
557 (narrow-to-region (point-min) (point))
558 (setq charset (mail-fetch-field "charset")))
559 (if (and (mm-uu-pgp-encrypted-test)
561 (mml2015-clean-buffer)
562 (funcall (mml2015-clear-decrypt-function))
563 (equal (mm-handle-multipart-ctl-parameter mm-security-handle
569 (setq charset gnus-newsgroup-charset))
570 (setq charset (mm-charset-to-coding-system charset))
571 (not (eq charset 'ascii)))
572 ;; Assume that buffer's multibyteness is turned off.
573 ;; See `mml2015-pgg-clear-decrypt'.
574 (insert (mm-decode-coding-string (prog1
577 (mm-enable-multibyte))
579 (mm-enable-multibyte))
580 (list (mm-make-handle buf mm-uu-text-plain-type)))
581 (list (mm-make-handle buf '("application/pgp-encrypted")))))))
583 (defun mm-uu-pgp-encrypted-extract ()
584 (let ((mm-security-handle (list (format "multipart/encrypted"))))
585 (mm-set-handle-multipart-parameter
586 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
588 (narrow-to-region start-point end-point)
589 (add-text-properties 0 (length (car mm-security-handle))
590 (list 'buffer (mm-uu-copy-to-buffer))
591 (car mm-security-handle))
592 (setcdr mm-security-handle
593 (mm-uu-pgp-encrypted-extract-1 nil
594 mm-security-handle)))
597 (defun mm-uu-gpg-key-skip-to-last ()
598 (let ((point (point))
599 (end-regexp (mm-uu-end-regexp entry))
600 (beginning-regexp (mm-uu-beginning-regexp entry)))
601 (when (and end-regexp
602 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
603 (while (re-search-forward end-regexp nil t)
604 (skip-chars-forward " \t\n\r")
605 (if (looking-at beginning-regexp)
606 (setq point (match-end 0)))))
609 (defun mm-uu-pgp-key-extract ()
610 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
612 '("application/pgp-keys"))))
615 (defun mm-uu-dissect (&optional noheader mime-type)
616 "Dissect the current buffer and return a list of uu handles.
617 The optional NOHEADER means there's no header in the buffer.
618 MIME-TYPE specifies a MIME type and parameters, which defaults to the
619 value of `mm-uu-text-plain-type'."
620 (let ((case-fold-search t)
621 (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
622 text-start start-point end-point file-name result entry func)
624 (goto-char (point-min))
629 ((search-forward "\n\n" nil t)
631 (t (goto-char (point-max))))
632 (setq text-start (point))
633 (while (re-search-forward mm-uu-beginning-regexp nil t)
634 (setq start-point (match-beginning 0)
636 (let ((alist mm-uu-type-alist)
637 (beginning-regexp (match-string 0)))
639 (if (string-match (mm-uu-beginning-regexp (car alist))
641 (setq entry (car alist))
643 (if (setq func (mm-uu-function-1 entry))
645 (forward-line);; in case of failure
646 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
647 (let ((end-regexp (mm-uu-end-regexp entry)))
649 (or (setq end-point (point-max)) t)
651 (re-search-forward end-regexp nil t)
653 (setq end-point (point)))))
654 (or (not (setq func (mm-uu-function-2 entry)))
656 (if (and (> start-point text-start)
658 (goto-char text-start)
659 (re-search-forward "." start-point t)))
661 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
662 mm-uu-text-plain-type)
665 (funcall (mm-uu-function-extract entry))
667 (goto-char (setq text-start end-point))))
669 (if (and (> (point-max) (1+ text-start))
671 (goto-char text-start)
672 (re-search-forward "." nil t)))
674 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
675 mm-uu-text-plain-type)
677 (setq result (cons "multipart/mixed" (nreverse result))))
681 (defun mm-uu-dissect-text-parts (handle &optional decoded)
682 "Dissect text parts and put uu handles into HANDLE.
683 Assume text has been decoded if DECODED is non-nil."
684 (let ((buffer (mm-handle-buffer handle)))
685 (cond ((stringp buffer)
686 (dolist (elem (cdr handle))
687 (mm-uu-dissect-text-parts elem decoded)))
689 (let ((type (mm-handle-media-type handle))
690 (case-fold-search t) ;; string-match
691 children charset encoding)
694 ;; Mutt still uses application/pgp even though
695 ;; it has already been withdrawn.
696 (string-match "\\`text/\\|\\`application/pgp\\'" type)
699 (with-current-buffer buffer
702 (eq (setq charset (mail-content-type-get
703 (mm-handle-type handle)
708 t (cons type '((charset . gnus-decoded)))))
711 (mm-with-multibyte-buffer
712 (insert (mm-decode-string (mm-get-part handle)
715 t (cons type '((charset . gnus-decoded))))))
716 ((setq encoding (mm-handle-encoding handle))
718 ;; Inherit the multibyteness of the `buffer'.
720 (insert-buffer-substring buffer)
721 (mm-decode-content-transfer-encoding
723 (mm-uu-dissect t (list type))))
726 (mm-uu-dissect t (list type)))))))
727 ;; Ignore it if a given part is dissected into a single
728 ;; part of which the type is the same as the given one.
729 (if (and (<= (length children) 2)
730 (string-equal (mm-handle-media-type (cadr children))
732 (kill-buffer (mm-handle-buffer (cadr children)))
734 (setcdr handle (cdr children))
735 (setcar handle (car children)) ;; "multipart/mixed"
736 (dolist (elem (cdr children))
737 (mm-uu-dissect-text-parts elem decoded))))))
739 (dolist (elem handle)
740 (mm-uu-dissect-text-parts elem decoded))))))
744 ;;; mm-uu.el ends here