1 ;;; mm-uu.el --- Return uu stuff as mm handles
2 ;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003, 2004
3 ;; Free Software Foundation, Inc.
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
8 ;; This file is part of GNU Emacs.
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 2, or (at your option)
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
29 (eval-when-compile (require 'cl))
33 (require 'gnus-mailcap)
36 (autoload 'uudecode-decode-region "uudecode")
37 (autoload 'uudecode-decode-region-external "uudecode")
38 (autoload 'uudecode-decode-region-internal "uudecode")
40 (autoload 'binhex-decode-region "binhex")
41 (autoload 'binhex-decode-region-external "binhex")
42 (autoload 'binhex-decode-region-internal "binhex")
44 (autoload 'yenc-decode-region "yenc")
45 (autoload 'yenc-extract-filename "yenc")
47 (defcustom mm-uu-decode-function 'uudecode-decode-region
48 "*Function to uudecode.
49 Internal function is done in Lisp by default, therefore decoding may
50 appear to be horribly slow. You can make Gnus use an external
51 decoder, such as uudecode."
53 (function-item :tag "Auto detect" uudecode-decode-region)
54 (function-item :tag "Internal" uudecode-decode-region-internal)
55 (function-item :tag "External" uudecode-decode-region-external))
56 :group 'gnus-article-mime)
58 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
59 "*Function to binhex decode.
60 Internal function is done in elisp by default, therefore decoding may
61 appear to be horribly slow . You can make Gnus use the external Unix
62 decoder, such as hexbin."
63 :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
64 (function-item :tag "Internal" binhex-decode-region-internal)
65 (function-item :tag "External" binhex-decode-region-external))
66 :group 'gnus-article-mime)
68 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
70 (defvar mm-uu-pgp-beginning-signature
71 "^-----BEGIN PGP SIGNATURE-----")
73 (defvar mm-uu-beginning-regexp nil)
75 (defvar mm-dissect-disposition "inline"
76 "The default disposition of uu parts.
77 This can be either \"inline\" or \"attachment\".")
79 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
80 "The regexp of Emacs sources groups.")
82 (defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
83 "*Regexp matching diff groups."
85 :group 'gnus-article-mime)
87 (defvar mm-uu-type-alist
91 mm-uu-postscript-extract
94 "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
99 "^:...............................................................$"
103 mm-uu-binhex-filename)
105 "^=ybegin.*size=[0-9]+.*name=.*$"
106 "^=yend.*size=[0-9]+"
114 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
115 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
116 "^-+ \\(Start of \\)?Forwarded message"
117 "^-+ End \\(of \\)?forwarded message"
118 mm-uu-forward-extract
122 "^----gnatsweb-attachment----"
124 mm-uu-gnatsweb-extract)
126 "^-----BEGIN PGP SIGNED MESSAGE-----"
127 "^-----END PGP SIGNATURE-----"
128 mm-uu-pgp-signed-extract
132 "^-----BEGIN PGP MESSAGE-----"
133 "^-----END PGP MESSAGE-----"
134 mm-uu-pgp-encrypted-extract
138 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
139 "^-----END PGP PUBLIC KEY BLOCK-----"
140 mm-uu-pgp-key-extract
141 mm-uu-gpg-key-skip-to-last
144 "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
145 "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
146 mm-uu-emacs-sources-extract
148 mm-uu-emacs-sources-test)
156 (defcustom mm-uu-configure-list '((shar . disabled))
157 "A list of mm-uu configuration.
158 To disable dissecting shar codes, for instance, add
159 `(shar . disabled)' to this list."
161 :options (mapcar (lambda (entry)
162 (list (car entry) '(const disabled)))
164 :group 'gnus-article-mime)
166 (defvar mm-uu-text-plain-type '("text/plain" (charset . gnus-decoded))
167 "MIME type and parameters for text/plain parts.
168 `gnus-decoded' is a fake charset, which means no further decoding.")
172 (defsubst mm-uu-type (entry)
175 (defsubst mm-uu-beginning-regexp (entry)
178 (defsubst mm-uu-end-regexp (entry)
181 (defsubst mm-uu-function-extract (entry)
184 (defsubst mm-uu-function-1 (entry)
187 (defsubst mm-uu-function-2 (entry)
190 (defun mm-uu-copy-to-buffer (&optional from to)
191 "Copy the contents of the current buffer to a fresh buffer.
194 (let ((obuf (current-buffer))
196 ;; Might not exist in non-MULE XEmacs
197 (when (boundp 'buffer-file-coding-system)
198 buffer-file-coding-system)))
199 (set-buffer (generate-new-buffer " *mm-uu*"))
200 (setq buffer-file-coding-system coding-system)
201 (insert-buffer-substring obuf from to)
204 (defun mm-uu-configure-p (key val)
205 (member (cons key val) mm-uu-configure-list))
207 (defun mm-uu-configure (&optional symbol value)
208 (if symbol (set-default symbol value))
209 (setq mm-uu-beginning-regexp nil)
210 (mapcar (lambda (entry)
211 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
213 (setq mm-uu-beginning-regexp
214 (concat mm-uu-beginning-regexp
215 (if mm-uu-beginning-regexp "\\|")
216 (mm-uu-beginning-regexp entry)))))
227 (defun mm-uu-uu-filename ()
228 (if (looking-at ".+")
230 (let ((nnheader-file-name-translation-alist
231 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_))))
232 (nnheader-translate-file-chars (match-string 0))))))
234 (defun mm-uu-binhex-filename ()
237 (binhex-decode-region start-point end-point t))))
239 (defun mm-uu-yenc-filename ()
240 (goto-char start-point)
243 (yenc-extract-filename))))
245 (defun mm-uu-forward-test ()
247 (goto-char start-point)
249 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
251 (defun mm-uu-postscript-extract ()
252 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
253 '("application/postscript")))
255 (defun mm-uu-emacs-sources-extract ()
256 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
257 '("application/emacs-lisp")
259 (list mm-dissect-disposition
260 (cons 'filename file-name))))
263 (defvar gnus-newsgroup-name))
265 (defun mm-uu-emacs-sources-test ()
266 (setq file-name (match-string 1))
267 (and gnus-newsgroup-name
268 mm-uu-emacs-sources-regexp
269 (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
271 (defun mm-uu-diff-extract ()
272 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
275 (defun mm-uu-diff-test ()
276 (and gnus-newsgroup-name
277 mm-uu-diff-groups-regexp
278 (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
280 (defun mm-uu-forward-extract ()
281 (mm-make-handle (mm-uu-copy-to-buffer
282 (progn (goto-char start-point) (forward-line) (point))
283 (progn (goto-char end-point) (forward-line -1) (point)))
284 '("message/rfc822" (charset . gnus-decoded))))
286 (defun mm-uu-uu-extract ()
287 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
288 (list (or (and file-name
289 (string-match "\\.[^\\.]+$"
291 (mailcap-extension-to-mime
292 (match-string 0 file-name)))
293 "application/octet-stream"))
295 (if (and file-name (not (equal file-name "")))
296 (list mm-dissect-disposition
297 (cons 'filename file-name)))))
299 (defun mm-uu-binhex-extract ()
300 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
301 (list (or (and file-name
302 (string-match "\\.[^\\.]+$" file-name)
303 (mailcap-extension-to-mime
304 (match-string 0 file-name)))
305 "application/octet-stream"))
307 (if (and file-name (not (equal file-name "")))
308 (list mm-dissect-disposition
309 (cons 'filename file-name)))))
311 (defun mm-uu-yenc-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"))
319 (if (and file-name (not (equal file-name "")))
320 (list mm-dissect-disposition
321 (cons 'filename file-name)))))
324 (defun mm-uu-shar-extract ()
325 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
326 '("application/x-shar")))
328 (defun mm-uu-gnatsweb-extract ()
330 (goto-char start-point)
332 (narrow-to-region (point) end-point)
333 (mm-dissect-buffer t)))
335 (defun mm-uu-pgp-signed-test (&rest rest)
338 (mml2015-clear-verify-function)
340 ((eq mm-verify-option 'never) nil)
341 ((eq mm-verify-option 'always) t)
342 ((eq mm-verify-option 'known) t)
343 (t (y-or-n-p "Verify pgp signed part? ")))))
346 (defvar gnus-newsgroup-charset))
348 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
349 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
350 (with-current-buffer buf
351 (if (mm-uu-pgp-signed-test)
353 (mml2015-clean-buffer)
354 (let ((coding-system-for-write (or gnus-newsgroup-charset
356 (funcall (mml2015-clear-verify-function))))
357 (when (and mml2015-use (null (mml2015-clear-verify-function)))
358 (mm-set-handle-multipart-parameter
359 mm-security-handle 'gnus-details
360 (format "Clear verification not supported by `%s'.\n" mml2015-use))))
361 (goto-char (point-min))
362 (if (search-forward "\n\n" nil t)
363 (delete-region (point-min) (point)))
364 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
365 (delete-region (match-beginning 0) (point-max)))
366 (goto-char (point-min))
367 (while (re-search-forward "^- " nil t)
368 (replace-match "" t t)
370 (list (mm-make-handle buf mm-uu-text-plain-type))))
372 (defun mm-uu-pgp-signed-extract ()
373 (let ((mm-security-handle (list (format "multipart/signed"))))
374 (mm-set-handle-multipart-parameter
375 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
377 (narrow-to-region start-point end-point)
378 (add-text-properties 0 (length (car mm-security-handle))
379 (list 'buffer (mm-uu-copy-to-buffer))
380 (car mm-security-handle))
381 (setcdr mm-security-handle
382 (mm-uu-pgp-signed-extract-1 nil
383 mm-security-handle)))
386 (defun mm-uu-pgp-encrypted-test (&rest rest)
389 (mml2015-clear-decrypt-function)
391 ((eq mm-decrypt-option 'never) nil)
392 ((eq mm-decrypt-option 'always) t)
393 ((eq mm-decrypt-option 'known) t)
394 (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
396 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
397 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
398 (if (mm-uu-pgp-encrypted-test)
399 (with-current-buffer buf
400 (mml2015-clean-buffer)
401 (funcall (mml2015-clear-decrypt-function))))
402 (list (mm-make-handle buf mm-uu-text-plain-type))))
404 (defun mm-uu-pgp-encrypted-extract ()
405 (let ((mm-security-handle (list (format "multipart/encrypted"))))
406 (mm-set-handle-multipart-parameter
407 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
409 (narrow-to-region start-point end-point)
410 (add-text-properties 0 (length (car mm-security-handle))
411 (list 'buffer (mm-uu-copy-to-buffer))
412 (car mm-security-handle))
413 (setcdr mm-security-handle
414 (mm-uu-pgp-encrypted-extract-1 nil
415 mm-security-handle)))
418 (defun mm-uu-gpg-key-skip-to-last ()
419 (let ((point (point))
420 (end-regexp (mm-uu-end-regexp entry))
421 (beginning-regexp (mm-uu-beginning-regexp entry)))
422 (when (and end-regexp
423 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
424 (while (re-search-forward end-regexp nil t)
425 (skip-chars-forward " \t\n\r")
426 (if (looking-at beginning-regexp)
427 (setq point (match-end 0)))))
430 (defun mm-uu-pgp-key-extract ()
431 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
433 '("application/pgp-keys"))))
436 (defun mm-uu-dissect (&optional noheader mime-type)
437 "Dissect the current buffer and return a list of uu handles.
438 The optional NOHEADER means there's no header in the buffer.
439 MIME-TYPE specifies a MIME type and parameters, which defaults to the
440 value of `mm-uu-text-plain-type'."
441 (let ((case-fold-search t)
442 (mm-uu-text-plain-type (or mime-type mm-uu-text-plain-type))
443 text-start start-point end-point file-name result entry func)
445 (goto-char (point-min))
450 ((search-forward "\n\n" nil t)
452 (t (goto-char (point-max))))
453 (setq text-start (point))
454 (while (re-search-forward mm-uu-beginning-regexp nil t)
455 (setq start-point (match-beginning 0))
456 (let ((alist mm-uu-type-alist)
457 (beginning-regexp (match-string 0)))
459 (if (string-match (mm-uu-beginning-regexp (car alist))
461 (setq entry (car alist))
463 (if (setq func (mm-uu-function-1 entry))
465 (forward-line);; in case of failure
466 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
467 (let ((end-regexp (mm-uu-end-regexp entry)))
469 (or (setq end-point (point-max)) t)
471 (re-search-forward end-regexp nil t)
473 (setq end-point (point)))))
474 (or (not (setq func (mm-uu-function-2 entry)))
476 (if (and (> start-point text-start)
478 (goto-char text-start)
479 (re-search-forward "." start-point t)))
481 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
482 mm-uu-text-plain-type)
485 (funcall (mm-uu-function-extract entry))
487 (goto-char (setq text-start end-point))))
489 (if (and (> (point-max) (1+ text-start))
491 (goto-char text-start)
492 (re-search-forward "." nil t)))
494 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
495 mm-uu-text-plain-type)
497 (setq result (cons "multipart/mixed" (nreverse result))))
500 (defun mm-uu-dissect-text-parts (handle)
501 "Dissect text parts and put uu handles into HANDLE."
502 (let ((buffer (mm-handle-buffer handle))
504 (cond ((stringp buffer)
505 (mapc 'mm-uu-dissect-text-parts (cdr handle)))
507 (when (and (setq type (mm-handle-media-type handle))
509 (string-match "\\`text/" type)
510 (with-current-buffer buffer
512 (mm-uu-dissect t (mm-handle-type handle)))))
514 (setcar handle (car children))
515 (setcdr handle (cdr children))))
517 (mapc 'mm-uu-dissect-text-parts handle)))))
521 ;;; mm-uu.el ends here