Identify unsafe combinations of Bcc and encryption
[gnus] / lisp / mm-uu.el
1 ;;; mm-uu.el --- Return uu stuff as mm handles
2
3 ;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
4
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
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
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
25 ;;; Code:
26
27 (eval-when-compile (require 'cl))
28 (require 'mail-parse)
29 (require 'nnheader)
30 (require 'mm-decode)
31 (require 'mailcap)
32 (require 'mml2015)
33
34 (autoload 'uudecode-decode-region "uudecode")
35 (autoload 'uudecode-decode-region-external "uudecode")
36 (autoload 'uudecode-decode-region-internal "uudecode")
37
38 (autoload 'binhex-decode-region "binhex")
39 (autoload 'binhex-decode-region-external "binhex")
40 (autoload 'binhex-decode-region-internal "binhex")
41
42 (autoload 'yenc-decode-region "yenc")
43 (autoload 'yenc-extract-filename "yenc")
44
45 (defcustom mm-uu-decode-function 'uudecode-decode-region
46   "*Function to uudecode.
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
49 decoder, such as uudecode."
50   :type '(choice
51           (function-item :tag "Auto detect" uudecode-decode-region)
52           (function-item :tag "Internal" uudecode-decode-region-internal)
53           (function-item :tag "External" uudecode-decode-region-external))
54   :group 'gnus-article-mime)
55
56 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
57   "*Function to binhex decode.
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
60 decoder, such as hexbin."
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))
64   :group 'gnus-article-mime)
65
66 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
67
68 (defvar mm-uu-beginning-regexp nil)
69
70 (defvar mm-dissect-disposition "inline"
71   "The default disposition of uu parts.
72 This can be either \"inline\" or \"attachment\".")
73
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)
79
80 (defcustom mm-uu-diff-groups-regexp
81   "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)"
82   "Regexp matching diff groups."
83   :version "22.1"
84   :type 'regexp
85   :group 'gnus-article-mime)
86
87 (defcustom mm-uu-tex-groups-regexp "\\.tex\\>"
88   "*Regexp matching TeX groups."
89   :version "23.1"
90   :type 'regexp
91   :group 'gnus-article-mime)
92
93 (defvar mm-uu-type-alist
94   '((postscript
95      "^%!PS-"
96      "^%%EOF$"
97      mm-uu-postscript-extract
98      nil)
99     (uu ;; Maybe we should have a more strict test here.
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
105      "^:.\\{63,63\\}$"
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
120      ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
121      ;; Peter von der Ahé <pahe@daimi.au.dk>
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
160      mm-uu-diff-test)
161     (diff
162      "^=== modified file "
163      nil
164      mm-uu-diff-extract
165      nil
166      mm-uu-diff-test)
167     (git-format-patch
168      "^diff --git "
169      "^-- "
170      mm-uu-diff-extract
171      nil
172      mm-uu-diff-test)
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<>]*-+$"
179      (lambda () (mm-uu-verbatim-marks-extract 0 0 1 -1))
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
190      ;; http://slrn.sourceforge.net/docs/slrn-manual-6.html#process_verbatim_marks
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
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))
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
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'.")
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
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
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
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))
265   :version "23.1" ;; No Gnus
266   :group 'gnus-article-mime)
267
268 (defface mm-uu-extract '(;; Inspired by `gnus-cite-3'
269                          (((type tty)
270                            (class color)
271                            (background dark))
272                           (:background "dark blue"))
273                          (((class color)
274                            (background dark))
275                           (:foreground "light yellow"
276                            :background "dark green"))
277                          (((type tty)
278                            (class color)
279                            (background light))
280                           (:foreground "dark blue"))
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'.
289   :version "23.1" ;; No Gnus
290   :group 'gnus-article-mime)
291
292 (defun mm-uu-copy-to-buffer (&optional from to properties)
293   "Copy the contents of the current buffer to a fresh buffer.
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'."
299   (let ((obuf (current-buffer))
300         (multi (and (boundp 'enable-multibyte-characters)
301                     enable-multibyte-characters))
302         (coding-system
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*")
307       (if multi (mm-enable-multibyte) (mm-disable-multibyte))
308       (setq buffer-file-coding-system coding-system)
309       (insert-buffer-substring obuf from to)
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)))
315       (current-buffer))))
316
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)
321   "Configure detection of non-MIME attachments."
322   (interactive)
323   (if symbol (set-default symbol value))
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))
333
334 (mm-uu-configure)
335
336 (defvar file-name)
337 (defvar start-point)
338 (defvar end-point)
339 (defvar entry)
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
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
398 (defun mm-uu-emacs-sources-extract ()
399   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
400                   '("application/emacs-lisp" (charset . gnus-decoded))
401                   nil nil
402                   (list mm-dissect-disposition
403                         (cons 'filename file-name))))
404
405 (defun mm-uu-org-src-code-block-extract ()
406   (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
407                   '("text/x-org")))
408
409 (defvar gnus-newsgroup-name)
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)
419                   '("text/x-patch" (charset . gnus-decoded))))
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
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
431 (defun mm-uu-forward-extract ()
432   (mm-make-handle (mm-uu-copy-to-buffer
433                    (progn
434                      (goto-char start-point)
435                      (forward-line)
436                      (skip-chars-forward "\n")
437                      (point))
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
466 (defvar gnus-original-article-buffer)   ; gnus.el
467
468 (defun mm-uu-yenc-extract ()
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
471   ;; non-binary charset.  So get it from the original article buffer.
472   (mm-make-handle (with-current-buffer gnus-original-article-buffer
473                     (mm-uu-copy-to-buffer start-point end-point))
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)
504     (t (prog1
505            (y-or-n-p "Verify pgp signed part? ")
506          (message ""))))))
507
508 (defvar gnus-newsgroup-charset)
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)
516             (let ((coding-system-for-write (or buffer-file-coding-system
517                                                gnus-newsgroup-charset
518                                                'iso-8859-1))
519                   (coding-system-for-read (or buffer-file-coding-system
520                                               gnus-newsgroup-charset
521                                               'iso-8859-1)))
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
526            (gnus-format-message
527             "Clear verification not supported by `%s'.\n" mml2015-use)))
528         (mml2015-extract-cleartext-signature))
529       (list (mm-make-handle buf mm-uu-text-plain-type)))))
530
531 (defun mm-uu-pgp-signed-extract ()
532   (let ((mm-security-handle (list (format "multipart/signed"))))
533     (mm-set-handle-multipart-parameter
534      mm-security-handle 'protocol "application/x-gnus-pgp-signature")
535     (save-restriction
536       (narrow-to-region start-point end-point)
537       (add-text-properties 0 (length (car mm-security-handle))
538                            (list 'buffer (mm-uu-copy-to-buffer))
539                            (car mm-security-handle))
540       (setcdr mm-security-handle
541               (mm-uu-pgp-signed-extract-1 nil
542                                           mm-security-handle)))
543     mm-security-handle))
544
545 (defun mm-uu-pgp-encrypted-test (&rest rest)
546   (and
547    mml2015-use
548    (mml2015-clear-decrypt-function)
549    (cond
550     ((eq mm-decrypt-option 'never) nil)
551     ((eq mm-decrypt-option 'always) t)
552     ((eq mm-decrypt-option 'known) t)
553     (t (prog1
554            (y-or-n-p "Decrypt pgp encrypted part? ")
555          (message ""))))))
556
557 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
558   (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
559         (first t)
560         charset)
561     ;; Make sure there's a blank line between header and body.
562     (with-current-buffer buf
563       (goto-char (point-min))
564       (while (prog2
565                  (forward-line 1)
566                  (if first
567                      (looking-at "[^\t\n ]+:")
568                    (looking-at "[^\t\n ]+:\\|[\t ]"))
569                (setq first nil)))
570       (unless (memq (char-after) '(?\n nil))
571         (insert "\n"))
572       (save-restriction
573         (narrow-to-region (point-min) (point))
574         (setq charset (mail-fetch-field "charset")))
575       (if (and (mm-uu-pgp-encrypted-test)
576                (progn
577                  (mml2015-clean-buffer)
578                  (funcall (mml2015-clear-decrypt-function))
579                  (equal (mm-handle-multipart-ctl-parameter mm-security-handle
580                                                            'gnus-info)
581                         "OK")))
582           (progn
583             ;; Decode charset.
584             (if (and (or charset
585                          (setq charset gnus-newsgroup-charset))
586                      (setq charset (mm-charset-to-coding-system charset))
587                      (not (eq charset 'ascii)))
588                 ;; Assume that buffer's multibyteness is turned off.
589                 ;; See `mml2015-pgg-clear-decrypt'.
590                 (insert (mm-decode-coding-string (prog1
591                                                      (buffer-string)
592                                                    (erase-buffer)
593                                                    (mm-enable-multibyte))
594                                                  charset))
595               (mm-enable-multibyte))
596             (list (mm-make-handle buf mm-uu-text-plain-type)))
597         (list (mm-make-handle buf '("application/pgp-encrypted")))))))
598
599 (defun mm-uu-pgp-encrypted-extract ()
600   (let ((mm-security-handle (list (format "multipart/encrypted"))))
601     (mm-set-handle-multipart-parameter
602      mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
603     (save-restriction
604       (narrow-to-region start-point end-point)
605       (add-text-properties 0 (length (car mm-security-handle))
606                            (list 'buffer (mm-uu-copy-to-buffer))
607                            (car mm-security-handle))
608       (setcdr mm-security-handle
609               (mm-uu-pgp-encrypted-extract-1 nil
610                                              mm-security-handle)))
611     mm-security-handle))
612
613 (defun mm-uu-gpg-key-skip-to-last ()
614   (let ((point (point))
615         (end-regexp (mm-uu-end-regexp entry))
616         (beginning-regexp (mm-uu-beginning-regexp entry)))
617     (when (and end-regexp
618                (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
619       (while (re-search-forward end-regexp nil t)
620         (skip-chars-forward " \t\n\r")
621         (if (looking-at beginning-regexp)
622             (setq point (match-end 0)))))
623     (goto-char point)))
624
625 (defun mm-uu-pgp-key-extract ()
626   (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
627     (mm-make-handle buf
628                     '("application/pgp-keys"))))
629
630 ;;;###autoload
631 (defun mm-uu-dissect (&optional noheader mime-type)
632   "Dissect the current buffer and return a list of uu handles.
633 The optional NOHEADER means there's no header in the buffer.
634 MIME-TYPE specifies a MIME type and parameters, which defaults to the
635 value of `mm-uu-text-plain-type'."
636   (let ((case-fold-search t)
637         (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
638         text-start start-point end-point file-name result entry func)
639     (save-excursion
640       (goto-char (point-min))
641       (cond
642        (noheader)
643        ((looking-at "\n")
644         (forward-line))
645        ((search-forward "\n\n" nil t)
646         t)
647        (t (goto-char (point-max))))
648       (setq text-start (point))
649       (while (re-search-forward mm-uu-beginning-regexp nil t)
650         (setq start-point (match-beginning 0)
651               entry nil)
652         (let ((alist mm-uu-type-alist)
653               (beginning-regexp (match-string 0)))
654           (while (not entry)
655             (if (string-match (mm-uu-beginning-regexp (car alist))
656                               beginning-regexp)
657                 (setq entry (car alist))
658               (pop alist))))
659         (if (setq func (mm-uu-function-1 entry))
660             (funcall func))
661         (forward-line);; in case of failure
662         (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
663                    (let ((end-regexp (mm-uu-end-regexp entry)))
664                      (if (not end-regexp)
665                          (or (setq end-point (point-max)) t)
666                        (prog1
667                            (re-search-forward end-regexp nil t)
668                          (forward-line)
669                          (setq end-point (point)))))
670                    (or (not (setq func (mm-uu-function-2 entry)))
671                        (funcall func)))
672           (if (and (> start-point text-start)
673                    (progn
674                      (goto-char text-start)
675                      (re-search-forward "." start-point t)))
676               (push
677                (mm-make-handle
678                 (mm-uu-copy-to-buffer
679                  text-start
680                  ;; A start-separator is likely accompanied by
681                  ;; a leading newline.
682                  (if (and (eq (char-before start-point) ?\n)
683                           (eq (char-before (1- start-point)) ?\n))
684                      (1- start-point)
685                    start-point))
686                 mm-uu-text-plain-type)
687                result))
688           (push
689            (funcall (mm-uu-function-extract entry))
690            result)
691           (goto-char (setq text-start end-point))))
692       (when result
693         (goto-char text-start)
694         (when (re-search-forward "." nil t)
695           (push (mm-make-handle
696                  (mm-uu-copy-to-buffer
697                   ;; An end-separator is likely accompanied by
698                   ;; a trailing newline.
699                   (if (eq (char-after text-start) ?\n)
700                       (1+ text-start)
701                     text-start)
702                   (point-max))
703                  mm-uu-text-plain-type)
704                 result))
705         (setq result (cons "multipart/mixed" (nreverse result))))
706       result)))
707
708 ;;;###autoload
709 (defun mm-uu-dissect-text-parts (handle &optional decoded)
710   "Dissect text parts and put uu handles into HANDLE.
711 Assume text has been decoded if DECODED is non-nil."
712   (let ((buffer (mm-handle-buffer handle)))
713     (cond ((stringp buffer)
714            (dolist (elem (cdr handle))
715              (mm-uu-dissect-text-parts elem decoded)))
716           ((bufferp buffer)
717            (let ((type (mm-handle-media-type handle))
718                  (case-fold-search t) ;; string-match
719                  children charset encoding)
720              (when (and
721                     (stringp type)
722                     ;; Mutt still uses application/pgp even though
723                     ;; it has already been withdrawn.
724                     (string-match "\\`text/\\|\\`application/pgp\\'" type)
725                     (equal (car (mm-handle-disposition handle))
726                            "inline")
727                     (setq
728                      children
729                      (with-current-buffer buffer
730                        (cond
731                         ((or decoded
732                              (eq (setq charset (mail-content-type-get
733                                                 (mm-handle-type handle)
734                                                 'charset))
735                                  'gnus-decoded))
736                          (setq decoded t)
737                          (mm-uu-dissect
738                           t (cons type '((charset . gnus-decoded)))))
739                         (charset
740                          (setq decoded t)
741                          (mm-with-multibyte-buffer
742                            (insert (mm-decode-string (mm-get-part handle)
743                                                      charset))
744                            (mm-uu-dissect
745                             t (cons type '((charset . gnus-decoded))))))
746                         ((setq encoding (mm-handle-encoding handle))
747                          (setq decoded nil)
748                          ;; Inherit the multibyteness of the `buffer'.
749                          (with-temp-buffer
750                            (insert-buffer-substring buffer)
751                            (mm-decode-content-transfer-encoding
752                             encoding type)
753                            (mm-uu-dissect t (list type))))
754                         (t
755                          (setq decoded nil)
756                          (mm-uu-dissect t (list type)))))))
757                ;; Ignore it if a given part is dissected into a single
758                ;; part of which the type is the same as the given one.
759                (if (and (<= (length children) 2)
760                         (string-equal (mm-handle-media-type (cadr children))
761                                       type))
762                    (kill-buffer (mm-handle-buffer (cadr children)))
763                  (kill-buffer buffer)
764                  (setcdr handle (cdr children))
765                  (setcar handle (car children)) ;; "multipart/mixed"
766                  (dolist (elem (cdr children))
767                    (mm-uu-dissect-text-parts elem decoded))))))
768           (t
769            (dolist (elem handle)
770              (mm-uu-dissect-text-parts elem decoded))))))
771
772 (provide 'mm-uu)
773
774 ;; Local Variables:
775 ;; coding: utf-8
776 ;; End:
777
778 ;;; mm-uu.el ends here