1 ;;; mm-uu.el --- Return uu stuff as mm handles
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005 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 2, or (at your option)
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; 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.
30 (eval-when-compile (require 'cl))
34 (require 'gnus-mailcap)
37 (autoload 'uudecode-decode-region "uudecode")
38 (autoload 'uudecode-decode-region-external "uudecode")
39 (autoload 'uudecode-decode-region-internal "uudecode")
41 (autoload 'binhex-decode-region "binhex")
42 (autoload 'binhex-decode-region-external "binhex")
43 (autoload 'binhex-decode-region-internal "binhex")
45 (autoload 'yenc-decode-region "yenc")
46 (autoload 'yenc-extract-filename "yenc")
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."
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)
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)
69 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
71 (defvar mm-uu-pgp-beginning-signature
72 "^-----BEGIN PGP SIGNATURE-----")
74 (defvar mm-uu-beginning-regexp nil)
76 (defvar mm-dissect-disposition "inline"
77 "The default disposition of uu parts.
78 This can be either \"inline\" or \"attachment\".")
80 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
81 "The regexp of Emacs sources groups.")
83 (defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
84 "*Regexp matching diff groups."
87 :group 'gnus-article-mime)
89 (defvar mm-uu-type-alist
93 mm-uu-postscript-extract
96 "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
101 "^:...............................................................$"
105 mm-uu-binhex-filename)
107 "^=ybegin.*size=[0-9]+.*name=.*$"
108 "^=yend.*size=[0-9]+"
116 ;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
117 ;; Peter von der Ah\'e <pahe@daimi.au.dk>
118 "^-+ \\(Start of \\)?Forwarded message"
119 "^-+ End \\(of \\)?forwarded message"
120 mm-uu-forward-extract
124 "^----gnatsweb-attachment----"
126 mm-uu-gnatsweb-extract)
128 "^-----BEGIN PGP SIGNED MESSAGE-----"
129 "^-----END PGP SIGNATURE-----"
130 mm-uu-pgp-signed-extract
134 "^-----BEGIN PGP MESSAGE-----"
135 "^-----END PGP MESSAGE-----"
136 mm-uu-pgp-encrypted-extract
140 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
141 "^-----END PGP PUBLIC KEY BLOCK-----"
142 mm-uu-pgp-key-extract
143 mm-uu-gpg-key-skip-to-last
146 "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
147 "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
148 mm-uu-emacs-sources-extract
150 mm-uu-emacs-sources-test)
158 ;; slrn-style verbatim marks, see
159 ;; http://www.slrn.org/manual/slrn-manual-6.html#ss6.81
162 mm-uu-verbatim-marks-extract
165 (defcustom mm-uu-configure-list '((shar . disabled))
166 "A list of mm-uu configuration.
167 To disable dissecting shar codes, for instance, add
168 `(shar . disabled)' to this list."
170 :options (mapcar (lambda (entry)
171 (list (car entry) '(const disabled)))
173 :group 'gnus-article-mime)
175 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
176 "MIME type and parameters for text/plain parts.
177 `gnus-decoded' is a fake charset, which means no further decoding.")
181 (defsubst mm-uu-type (entry)
184 (defsubst mm-uu-beginning-regexp (entry)
187 (defsubst mm-uu-end-regexp (entry)
190 (defsubst mm-uu-function-extract (entry)
193 (defsubst mm-uu-function-1 (entry)
196 (defsubst mm-uu-function-2 (entry)
199 (defface mm-uu-extract
202 (:background "gray5"))
205 (:background "gray95"))
208 "Face for extracted buffers."
209 ;; See `mm-uu-verbatim-marks-extract'.
210 :version "23.0" ;; No Gnus
211 :group 'gnus-article-mime)
213 (defun mm-uu-copy-to-buffer (&optional from to properties)
214 "Copy the contents of the current buffer to a fresh buffer.
217 If PROPERTIES is non-nil, PROPERTIES are applied to the buffer,
218 see `set-text-properties'. If PROPERTIES equals t, this means to
219 apply the face `mm-uu-extract'."
220 (let ((obuf (current-buffer))
222 ;; Might not exist in non-MULE XEmacs
223 (when (boundp 'buffer-file-coding-system)
224 buffer-file-coding-system)))
225 (with-current-buffer (generate-new-buffer " *mm-uu*")
226 (setq buffer-file-coding-system coding-system)
227 (insert-buffer-substring obuf from to)
228 (cond ((eq properties t)
229 (set-text-properties (point-min) (point-max)
230 '(face mm-uu-extract)))
232 (set-text-properties (point-min) (point-max) properties)))
235 (defun mm-uu-configure-p (key val)
236 (member (cons key val) mm-uu-configure-list))
238 (defun mm-uu-configure (&optional symbol value)
239 (if symbol (set-default symbol value))
240 (setq mm-uu-beginning-regexp nil)
241 (mapcar (lambda (entry)
242 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
244 (setq mm-uu-beginning-regexp
245 (concat mm-uu-beginning-regexp
246 (if mm-uu-beginning-regexp "\\|")
247 (mm-uu-beginning-regexp entry)))))
258 (defun mm-uu-uu-filename ()
259 (if (looking-at ".+")
261 (let ((nnheader-file-name-translation-alist
262 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_))))
263 (nnheader-translate-file-chars (match-string 0))))))
265 (defun mm-uu-binhex-filename ()
268 (binhex-decode-region start-point end-point t))))
270 (defun mm-uu-yenc-filename ()
271 (goto-char start-point)
274 (yenc-extract-filename))))
276 (defun mm-uu-forward-test ()
278 (goto-char start-point)
280 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
282 (defun mm-uu-postscript-extract ()
283 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
284 '("application/postscript")))
286 (defun mm-uu-verbatim-marks-extract ()
288 (mm-uu-copy-to-buffer
289 (progn (goto-char start-point) (forward-line) (point))
290 (progn (goto-char end-point) (forward-line -1) (point))
294 (defun mm-uu-emacs-sources-extract ()
295 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
296 '("application/emacs-lisp")
298 (list mm-dissect-disposition
299 (cons 'filename file-name))))
302 (defvar gnus-newsgroup-name))
304 (defun mm-uu-emacs-sources-test ()
305 (setq file-name (match-string 1))
306 (and gnus-newsgroup-name
307 mm-uu-emacs-sources-regexp
308 (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
310 (defun mm-uu-diff-extract ()
311 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
314 (defun mm-uu-diff-test ()
315 (and gnus-newsgroup-name
316 mm-uu-diff-groups-regexp
317 (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
319 (defun mm-uu-forward-extract ()
320 (mm-make-handle (mm-uu-copy-to-buffer
321 (progn (goto-char start-point) (forward-line) (point))
322 (progn (goto-char end-point) (forward-line -1) (point)))
323 '("message/rfc822" (charset . gnus-decoded))))
325 (defun mm-uu-uu-extract ()
326 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
327 (list (or (and file-name
328 (string-match "\\.[^\\.]+$"
330 (mailcap-extension-to-mime
331 (match-string 0 file-name)))
332 "application/octet-stream"))
334 (if (and file-name (not (equal file-name "")))
335 (list mm-dissect-disposition
336 (cons 'filename file-name)))))
338 (defun mm-uu-binhex-extract ()
339 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
340 (list (or (and file-name
341 (string-match "\\.[^\\.]+$" file-name)
342 (mailcap-extension-to-mime
343 (match-string 0 file-name)))
344 "application/octet-stream"))
346 (if (and file-name (not (equal file-name "")))
347 (list mm-dissect-disposition
348 (cons 'filename file-name)))))
350 (defun mm-uu-yenc-extract ()
351 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
352 (list (or (and file-name
353 (string-match "\\.[^\\.]+$" file-name)
354 (mailcap-extension-to-mime
355 (match-string 0 file-name)))
356 "application/octet-stream"))
358 (if (and file-name (not (equal file-name "")))
359 (list mm-dissect-disposition
360 (cons 'filename file-name)))))
363 (defun mm-uu-shar-extract ()
364 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
365 '("application/x-shar")))
367 (defun mm-uu-gnatsweb-extract ()
369 (goto-char start-point)
371 (narrow-to-region (point) end-point)
372 (mm-dissect-buffer t)))
374 (defun mm-uu-pgp-signed-test (&rest rest)
377 (mml2015-clear-verify-function)
379 ((eq mm-verify-option 'never) nil)
380 ((eq mm-verify-option 'always) t)
381 ((eq mm-verify-option 'known) t)
382 (t (y-or-n-p "Verify pgp signed part? ")))))
385 (defvar gnus-newsgroup-charset))
387 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
388 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
389 (with-current-buffer buf
390 (if (mm-uu-pgp-signed-test)
392 (mml2015-clean-buffer)
393 (let ((coding-system-for-write (or gnus-newsgroup-charset
395 (funcall (mml2015-clear-verify-function))))
396 (when (and mml2015-use (null (mml2015-clear-verify-function)))
397 (mm-set-handle-multipart-parameter
398 mm-security-handle 'gnus-details
399 (format "Clear verification not supported by `%s'.\n" mml2015-use))))
400 (goto-char (point-min))
401 (if (search-forward "\n\n" nil t)
402 (delete-region (point-min) (point)))
403 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
404 (delete-region (match-beginning 0) (point-max)))
405 (goto-char (point-min))
406 (while (re-search-forward "^- " nil t)
407 (replace-match "" t t)
409 (list (mm-make-handle buf mm-uu-text-plain-type))))
411 (defun mm-uu-pgp-signed-extract ()
412 (let ((mm-security-handle (list (format "multipart/signed"))))
413 (mm-set-handle-multipart-parameter
414 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
416 (narrow-to-region start-point end-point)
417 (add-text-properties 0 (length (car mm-security-handle))
418 (list 'buffer (mm-uu-copy-to-buffer))
419 (car mm-security-handle))
420 (setcdr mm-security-handle
421 (mm-uu-pgp-signed-extract-1 nil
422 mm-security-handle)))
425 (defun mm-uu-pgp-encrypted-test (&rest rest)
428 (mml2015-clear-decrypt-function)
430 ((eq mm-decrypt-option 'never) nil)
431 ((eq mm-decrypt-option 'always) t)
432 ((eq mm-decrypt-option 'known) t)
433 (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
435 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
436 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
437 (if (mm-uu-pgp-encrypted-test)
438 (with-current-buffer buf
439 (mml2015-clean-buffer)
440 (funcall (mml2015-clear-decrypt-function))))
441 (list (mm-make-handle buf mm-uu-text-plain-type))))
443 (defun mm-uu-pgp-encrypted-extract ()
444 (let ((mm-security-handle (list (format "multipart/encrypted"))))
445 (mm-set-handle-multipart-parameter
446 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
448 (narrow-to-region start-point end-point)
449 (add-text-properties 0 (length (car mm-security-handle))
450 (list 'buffer (mm-uu-copy-to-buffer))
451 (car mm-security-handle))
452 (setcdr mm-security-handle
453 (mm-uu-pgp-encrypted-extract-1 nil
454 mm-security-handle)))
457 (defun mm-uu-gpg-key-skip-to-last ()
458 (let ((point (point))
459 (end-regexp (mm-uu-end-regexp entry))
460 (beginning-regexp (mm-uu-beginning-regexp entry)))
461 (when (and end-regexp
462 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
463 (while (re-search-forward end-regexp nil t)
464 (skip-chars-forward " \t\n\r")
465 (if (looking-at beginning-regexp)
466 (setq point (match-end 0)))))
469 (defun mm-uu-pgp-key-extract ()
470 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
472 '("application/pgp-keys"))))
475 (defun mm-uu-dissect (&optional noheader mime-type)
476 "Dissect the current buffer and return a list of uu handles.
477 The optional NOHEADER means there's no header in the buffer.
478 MIME-TYPE specifies a MIME type and parameters, which defaults to the
479 value of `mm-uu-text-plain-type'."
480 (let ((case-fold-search t)
481 (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
482 text-start start-point end-point file-name result entry func)
484 (goto-char (point-min))
489 ((search-forward "\n\n" nil t)
491 (t (goto-char (point-max))))
492 (setq text-start (point))
493 (while (re-search-forward mm-uu-beginning-regexp nil t)
494 (setq start-point (match-beginning 0))
495 (let ((alist mm-uu-type-alist)
496 (beginning-regexp (match-string 0)))
498 (if (string-match (mm-uu-beginning-regexp (car alist))
500 (setq entry (car alist))
502 (if (setq func (mm-uu-function-1 entry))
504 (forward-line);; in case of failure
505 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
506 (let ((end-regexp (mm-uu-end-regexp entry)))
508 (or (setq end-point (point-max)) t)
510 (re-search-forward end-regexp nil t)
512 (setq end-point (point)))))
513 (or (not (setq func (mm-uu-function-2 entry)))
515 (if (and (> start-point text-start)
517 (goto-char text-start)
518 (re-search-forward "." start-point t)))
520 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
521 mm-uu-text-plain-type)
524 (funcall (mm-uu-function-extract entry))
526 (goto-char (setq text-start end-point))))
528 (if (and (> (point-max) (1+ text-start))
530 (goto-char text-start)
531 (re-search-forward "." nil t)))
533 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
534 mm-uu-text-plain-type)
536 (setq result (cons "multipart/mixed" (nreverse result))))
539 (defun mm-uu-dissect-text-parts (handle)
540 "Dissect text parts and put uu handles into HANDLE."
541 (let ((buffer (mm-handle-buffer handle))
543 (cond ((stringp buffer)
544 (mapc 'mm-uu-dissect-text-parts (cdr handle)))
546 (when (and (setq type (mm-handle-media-type handle))
548 (string-match "\\`text/" type)
549 (with-current-buffer buffer
551 (mm-uu-dissect t (mm-handle-type handle)))))
553 (setcar handle (car children))
554 (setcdr handle (cdr children))))
556 (mapc 'mm-uu-dissect-text-parts handle)))))
560 ;;; mm-uu.el ends here