Merged from emacs@sv.gnu.org
[bpt/emacs.git] / lisp / gnus / mm-uu.el
1 ;;; mm-uu.el --- Return uu stuff as mm handles
2
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
5
6 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
7 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
8
9 ;; This file is part of GNU Emacs.
10
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 2, or (at your option)
14 ;; any later version.
15 ;;
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
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
25
26 ;;; Commentary:
27
28 ;;; Code:
29
30 (eval-when-compile (require 'cl))
31 (require 'mail-parse)
32 (require 'nnheader)
33 (require 'mm-decode)
34 (require 'mailcap)
35 (require 'mml2015)
36
37 (autoload 'uudecode-decode-region "uudecode")
38 (autoload 'uudecode-decode-region-external "uudecode")
39 (autoload 'uudecode-decode-region-internal "uudecode")
40
41 (autoload 'binhex-decode-region "binhex")
42 (autoload 'binhex-decode-region-external "binhex")
43 (autoload 'binhex-decode-region-internal "binhex")
44
45 (autoload 'yenc-decode-region "yenc")
46 (autoload 'yenc-extract-filename "yenc")
47
48 (defcustom mm-uu-decode-function 'uudecode-decode-region
49 "*Function to uudecode.
50 Internal function is done in Lisp by default, therefore decoding may
51 appear to be horribly slow. You can make Gnus use an external
52 decoder, such as uudecode."
53 :type '(choice
54 (function-item :tag "Auto detect" uudecode-decode-region)
55 (function-item :tag "Internal" uudecode-decode-region-internal)
56 (function-item :tag "External" uudecode-decode-region-external))
57 :group 'gnus-article-mime)
58
59 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
60 "*Function to binhex decode.
61 Internal function is done in elisp by default, therefore decoding may
62 appear to be horribly slow . You can make Gnus use the external Unix
63 decoder, such as hexbin."
64 :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
65 (function-item :tag "Internal" binhex-decode-region-internal)
66 (function-item :tag "External" binhex-decode-region-external))
67 :group 'gnus-article-mime)
68
69 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
70
71 (defvar mm-uu-pgp-beginning-signature
72 "^-----BEGIN PGP SIGNATURE-----")
73
74 (defvar mm-uu-beginning-regexp nil)
75
76 (defvar mm-dissect-disposition "inline"
77 "The default disposition of uu parts.
78 This can be either \"inline\" or \"attachment\".")
79
80 (defcustom mm-uu-emacs-sources-regexp "\\.emacs\\.sources"
81 "The regexp of Emacs sources groups."
82 :version "22.1"
83 :type 'regexp
84 :group 'gnus-article-mime)
85
86 (defcustom mm-uu-diff-groups-regexp
87 "\\(gmane\\|gnu\\)\\..*\\(diff\\|commit\\|cvs\\|bug\\|devel\\)"
88 "Regexp matching diff groups."
89 :version "22.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
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 "^:...............................................................$"
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\'e <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 "A list of specifications for non-MIME attachments.
162 Each element consist of the following entries: label,
163 start-regexp, end-regexp, extract-function, test-function.
164
165 After modifying this list you must run \\[mm-uu-configure].")
166
167 (defcustom mm-uu-configure-list '((shar . disabled))
168 "A list of mm-uu configuration.
169 To disable dissecting shar codes, for instance, add
170 `(shar . disabled)' to this list."
171 :type 'alist
172 :options (mapcar (lambda (entry)
173 (list (car entry) '(const disabled)))
174 mm-uu-type-alist)
175 :group 'gnus-article-mime)
176
177 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
178 "MIME type and parameters for text/plain parts.
179 `gnus-decoded' is a fake charset, which means no further decoding.")
180
181 ;; functions
182
183 (defsubst mm-uu-type (entry)
184 (car entry))
185
186 (defsubst mm-uu-beginning-regexp (entry)
187 (nth 1 entry))
188
189 (defsubst mm-uu-end-regexp (entry)
190 (nth 2 entry))
191
192 (defsubst mm-uu-function-extract (entry)
193 (nth 3 entry))
194
195 (defsubst mm-uu-function-1 (entry)
196 (nth 4 entry))
197
198 (defsubst mm-uu-function-2 (entry)
199 (nth 5 entry))
200
201 (defun mm-uu-copy-to-buffer (&optional from to)
202 "Copy the contents of the current buffer to a fresh buffer.
203 Return that buffer."
204 (let ((obuf (current-buffer))
205 (coding-system
206 ;; Might not exist in non-MULE XEmacs
207 (when (boundp 'buffer-file-coding-system)
208 buffer-file-coding-system)))
209 (with-current-buffer (generate-new-buffer " *mm-uu*")
210 (setq buffer-file-coding-system coding-system)
211 (insert-buffer-substring obuf from to)
212 (current-buffer))))
213
214 (defun mm-uu-configure-p (key val)
215 (member (cons key val) mm-uu-configure-list))
216
217 (defun mm-uu-configure (&optional symbol value)
218 "Configure detection of non-MIME attachments."
219 (interactive)
220 (if symbol (set-default symbol value))
221 (setq mm-uu-beginning-regexp nil)
222 (mapcar (lambda (entry)
223 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
224 nil
225 (setq mm-uu-beginning-regexp
226 (concat mm-uu-beginning-regexp
227 (if mm-uu-beginning-regexp "\\|")
228 (mm-uu-beginning-regexp entry)))))
229 mm-uu-type-alist))
230
231 (mm-uu-configure)
232
233 (eval-when-compile
234 (defvar file-name)
235 (defvar start-point)
236 (defvar end-point)
237 (defvar entry))
238
239 (defun mm-uu-uu-filename ()
240 (if (looking-at ".+")
241 (setq file-name
242 (let ((nnheader-file-name-translation-alist
243 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_))))
244 (nnheader-translate-file-chars (match-string 0))))))
245
246 (defun mm-uu-binhex-filename ()
247 (setq file-name
248 (ignore-errors
249 (binhex-decode-region start-point end-point t))))
250
251 (defun mm-uu-yenc-filename ()
252 (goto-char start-point)
253 (setq file-name
254 (ignore-errors
255 (yenc-extract-filename))))
256
257 (defun mm-uu-forward-test ()
258 (save-excursion
259 (goto-char start-point)
260 (forward-line)
261 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
262
263 (defun mm-uu-postscript-extract ()
264 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
265 '("application/postscript")))
266
267 (defun mm-uu-emacs-sources-extract ()
268 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
269 '("application/emacs-lisp" (charset . gnus-decoded))
270 nil nil
271 (list mm-dissect-disposition
272 (cons 'filename file-name))))
273
274 (eval-when-compile
275 (defvar gnus-newsgroup-name))
276
277 (defun mm-uu-emacs-sources-test ()
278 (setq file-name (match-string 1))
279 (and gnus-newsgroup-name
280 mm-uu-emacs-sources-regexp
281 (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
282
283 (defun mm-uu-diff-extract ()
284 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
285 '("text/x-patch" (charset . gnus-decoded))))
286
287 (defun mm-uu-diff-test ()
288 (and gnus-newsgroup-name
289 mm-uu-diff-groups-regexp
290 (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
291
292 (defun mm-uu-forward-extract ()
293 (mm-make-handle (mm-uu-copy-to-buffer
294 (progn (goto-char start-point) (forward-line) (point))
295 (progn (goto-char end-point) (forward-line -1) (point)))
296 '("message/rfc822" (charset . gnus-decoded))))
297
298 (defun mm-uu-uu-extract ()
299 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
300 (list (or (and file-name
301 (string-match "\\.[^\\.]+$"
302 file-name)
303 (mailcap-extension-to-mime
304 (match-string 0 file-name)))
305 "application/octet-stream"))
306 'x-uuencode nil
307 (if (and file-name (not (equal file-name "")))
308 (list mm-dissect-disposition
309 (cons 'filename file-name)))))
310
311 (defun mm-uu-binhex-extract ()
312 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
313 (list (or (and file-name
314 (string-match "\\.[^\\.]+$" file-name)
315 (mailcap-extension-to-mime
316 (match-string 0 file-name)))
317 "application/octet-stream"))
318 'x-binhex nil
319 (if (and file-name (not (equal file-name "")))
320 (list mm-dissect-disposition
321 (cons 'filename file-name)))))
322
323 (defun mm-uu-yenc-extract ()
324 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
325 (list (or (and file-name
326 (string-match "\\.[^\\.]+$" file-name)
327 (mailcap-extension-to-mime
328 (match-string 0 file-name)))
329 "application/octet-stream"))
330 'x-yenc nil
331 (if (and file-name (not (equal file-name "")))
332 (list mm-dissect-disposition
333 (cons 'filename file-name)))))
334
335
336 (defun mm-uu-shar-extract ()
337 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
338 '("application/x-shar")))
339
340 (defun mm-uu-gnatsweb-extract ()
341 (save-restriction
342 (goto-char start-point)
343 (forward-line)
344 (narrow-to-region (point) end-point)
345 (mm-dissect-buffer t)))
346
347 (defun mm-uu-pgp-signed-test (&rest rest)
348 (and
349 mml2015-use
350 (mml2015-clear-verify-function)
351 (cond
352 ((eq mm-verify-option 'never) nil)
353 ((eq mm-verify-option 'always) t)
354 ((eq mm-verify-option 'known) t)
355 (t (prog1
356 (y-or-n-p "Verify pgp signed part? ")
357 (message ""))))))
358
359 (eval-when-compile
360 (defvar gnus-newsgroup-charset))
361
362 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
363 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
364 (with-current-buffer buf
365 (if (mm-uu-pgp-signed-test)
366 (progn
367 (mml2015-clean-buffer)
368 (let ((coding-system-for-write (or gnus-newsgroup-charset
369 'iso-8859-1)))
370 (funcall (mml2015-clear-verify-function))))
371 (when (and mml2015-use (null (mml2015-clear-verify-function)))
372 (mm-set-handle-multipart-parameter
373 mm-security-handle 'gnus-details
374 (format "Clear verification not supported by `%s'.\n" mml2015-use))))
375 (goto-char (point-min))
376 (forward-line)
377 ;; We need to be careful not to strip beyond the armor headers.
378 ;; Previously, an attacker could replace the text inside our
379 ;; markup with trailing garbage by injecting whitespace into the
380 ;; message.
381 (while (looking-at "Hash:") ; The only header allowed in cleartext
382 (forward-line)) ; signatures according to RFC2440.
383 (when (looking-at "[\t ]*$")
384 (forward-line))
385 (delete-region (point-min) (point))
386 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
387 (delete-region (match-beginning 0) (point-max)))
388 (goto-char (point-min))
389 (while (re-search-forward "^- " nil t)
390 (replace-match "" t t)
391 (forward-line 1)))
392 (list (mm-make-handle buf mm-uu-text-plain-type))))
393
394 (defun mm-uu-pgp-signed-extract ()
395 (let ((mm-security-handle (list (format "multipart/signed"))))
396 (mm-set-handle-multipart-parameter
397 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
398 (save-restriction
399 (narrow-to-region start-point end-point)
400 (add-text-properties 0 (length (car mm-security-handle))
401 (list 'buffer (mm-uu-copy-to-buffer))
402 (car mm-security-handle))
403 (setcdr mm-security-handle
404 (mm-uu-pgp-signed-extract-1 nil
405 mm-security-handle)))
406 mm-security-handle))
407
408 (defun mm-uu-pgp-encrypted-test (&rest rest)
409 (and
410 mml2015-use
411 (mml2015-clear-decrypt-function)
412 (cond
413 ((eq mm-decrypt-option 'never) nil)
414 ((eq mm-decrypt-option 'always) t)
415 ((eq mm-decrypt-option 'known) t)
416 (t (prog1
417 (y-or-n-p "Decrypt pgp encrypted part? ")
418 (message ""))))))
419
420 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
421 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max)))
422 (first t)
423 charset)
424 ;; Make sure there's a blank line between header and body.
425 (with-current-buffer buf
426 (goto-char (point-min))
427 (while (prog2
428 (forward-line 1)
429 (if first
430 (looking-at "[^\t\n ]+:")
431 (looking-at "[^\t\n ]+:\\|[\t ]"))
432 (setq first nil)))
433 (unless (memq (char-after) '(?\n nil))
434 (insert "\n"))
435 (save-restriction
436 (narrow-to-region (point-min) (point))
437 (setq charset (mail-fetch-field "charset")))
438 (if (and (mm-uu-pgp-encrypted-test)
439 (progn
440 (mml2015-clean-buffer)
441 (funcall (mml2015-clear-decrypt-function))
442 (equal (mm-handle-multipart-ctl-parameter mm-security-handle
443 'gnus-info)
444 "OK")))
445 (progn
446 ;; Decode charset.
447 (if (and (or charset
448 (setq charset gnus-newsgroup-charset))
449 (setq charset (mm-charset-to-coding-system charset))
450 (not (eq charset 'ascii)))
451 ;; Assume that buffer's multibyteness is turned off.
452 ;; See `mml2015-pgg-clear-decrypt'.
453 (insert (mm-decode-coding-string (prog1
454 (buffer-string)
455 (erase-buffer)
456 (mm-enable-multibyte))
457 charset))
458 (mm-enable-multibyte))
459 (list (mm-make-handle buf mm-uu-text-plain-type)))
460 (list (mm-make-handle buf '("application/pgp-encrypted")))))))
461
462 (defun mm-uu-pgp-encrypted-extract ()
463 (let ((mm-security-handle (list (format "multipart/encrypted"))))
464 (mm-set-handle-multipart-parameter
465 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
466 (save-restriction
467 (narrow-to-region start-point end-point)
468 (add-text-properties 0 (length (car mm-security-handle))
469 (list 'buffer (mm-uu-copy-to-buffer))
470 (car mm-security-handle))
471 (setcdr mm-security-handle
472 (mm-uu-pgp-encrypted-extract-1 nil
473 mm-security-handle)))
474 mm-security-handle))
475
476 (defun mm-uu-gpg-key-skip-to-last ()
477 (let ((point (point))
478 (end-regexp (mm-uu-end-regexp entry))
479 (beginning-regexp (mm-uu-beginning-regexp entry)))
480 (when (and end-regexp
481 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
482 (while (re-search-forward end-regexp nil t)
483 (skip-chars-forward " \t\n\r")
484 (if (looking-at beginning-regexp)
485 (setq point (match-end 0)))))
486 (goto-char point)))
487
488 (defun mm-uu-pgp-key-extract ()
489 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
490 (mm-make-handle buf
491 '("application/pgp-keys"))))
492
493 ;;;###autoload
494 (defun mm-uu-dissect (&optional noheader mime-type)
495 "Dissect the current buffer and return a list of uu handles.
496 The optional NOHEADER means there's no header in the buffer.
497 MIME-TYPE specifies a MIME type and parameters, which defaults to the
498 value of `mm-uu-text-plain-type'."
499 (let ((case-fold-search t)
500 (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
501 text-start start-point end-point file-name result entry func)
502 (save-excursion
503 (goto-char (point-min))
504 (cond
505 (noheader)
506 ((looking-at "\n")
507 (forward-line))
508 ((search-forward "\n\n" nil t)
509 t)
510 (t (goto-char (point-max))))
511 (setq text-start (point))
512 (while (re-search-forward mm-uu-beginning-regexp nil t)
513 (setq start-point (match-beginning 0)
514 entry nil)
515 (let ((alist mm-uu-type-alist)
516 (beginning-regexp (match-string 0)))
517 (while (not entry)
518 (if (string-match (mm-uu-beginning-regexp (car alist))
519 beginning-regexp)
520 (setq entry (car alist))
521 (pop alist))))
522 (if (setq func (mm-uu-function-1 entry))
523 (funcall func))
524 (forward-line);; in case of failure
525 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
526 (let ((end-regexp (mm-uu-end-regexp entry)))
527 (if (not end-regexp)
528 (or (setq end-point (point-max)) t)
529 (prog1
530 (re-search-forward end-regexp nil t)
531 (forward-line)
532 (setq end-point (point)))))
533 (or (not (setq func (mm-uu-function-2 entry)))
534 (funcall func)))
535 (if (and (> start-point text-start)
536 (progn
537 (goto-char text-start)
538 (re-search-forward "." start-point t)))
539 (push
540 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
541 mm-uu-text-plain-type)
542 result))
543 (push
544 (funcall (mm-uu-function-extract entry))
545 result)
546 (goto-char (setq text-start end-point))))
547 (when result
548 (if (and (> (point-max) (1+ text-start))
549 (save-excursion
550 (goto-char text-start)
551 (re-search-forward "." nil t)))
552 (push
553 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
554 mm-uu-text-plain-type)
555 result))
556 (setq result (cons "multipart/mixed" (nreverse result))))
557 result)))
558
559 ;;;###autoload
560 (defun mm-uu-dissect-text-parts (handle &optional decoded)
561 "Dissect text parts and put uu handles into HANDLE.
562 Assume text has been decoded if DECODED is non-nil."
563 (let ((buffer (mm-handle-buffer handle)))
564 (cond ((stringp buffer)
565 (dolist (elem (cdr handle))
566 (mm-uu-dissect-text-parts elem decoded)))
567 ((bufferp buffer)
568 (let ((type (mm-handle-media-type handle))
569 (case-fold-search t) ;; string-match
570 children charset encoding)
571 (when (and
572 (stringp type)
573 ;; Mutt still uses application/pgp even though
574 ;; it has already been withdrawn.
575 (string-match "\\`text/\\|\\`application/pgp\\'" type)
576 (setq
577 children
578 (with-current-buffer buffer
579 (cond
580 ((or decoded
581 (eq (setq charset (mail-content-type-get
582 (mm-handle-type handle)
583 'charset))
584 'gnus-decoded))
585 (setq decoded t)
586 (mm-uu-dissect
587 t (cons type '((charset . gnus-decoded)))))
588 (charset
589 (setq decoded t)
590 (mm-with-multibyte-buffer
591 (insert (mm-decode-string (mm-get-part handle)
592 charset))
593 (mm-uu-dissect
594 t (cons type '((charset . gnus-decoded))))))
595 ((setq encoding (mm-handle-encoding handle))
596 (setq decoded nil)
597 ;; Inherit the multibyteness of the `buffer'.
598 (with-temp-buffer
599 (insert-buffer-substring buffer)
600 (mm-decode-content-transfer-encoding
601 encoding type)
602 (mm-uu-dissect t (list type))))
603 (t
604 (setq decoded nil)
605 (mm-uu-dissect t (list type)))))))
606 ;; Ignore it if a given part is dissected into a single
607 ;; part of which the type is the same as the given one.
608 (if (and (<= (length children) 2)
609 (string-equal (mm-handle-media-type (cadr children))
610 type))
611 (kill-buffer (mm-handle-buffer (cadr children)))
612 (kill-buffer buffer)
613 (setcdr handle (cdr children))
614 (setcar handle (car children)) ;; "multipart/mixed"
615 (dolist (elem (cdr children))
616 (mm-uu-dissect-text-parts elem decoded))))))
617 (t
618 (dolist (elem handle)
619 (mm-uu-dissect-text-parts elem decoded))))))
620
621 (provide 'mm-uu)
622
623 ;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
624 ;;; mm-uu.el ends here