1 ;;; mm-uu.el -- Return uu stuffs as mm handles
2 ;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc.
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
29 (eval-when-compile (require 'cl))
37 (autoload 'binhex-decode-region "binhex")
38 (autoload 'binhex-decode-region-external "binhex")
39 (autoload 'uudecode-decode-region "uudecode")
40 (autoload 'uudecode-decode-region-external "uudecode"))
42 (defcustom mm-uu-decode-function 'uudecode-decode-region
43 "*Function to uudecode.
44 Internal function is done in elisp by default, therefore decoding may
45 appear to be horribly slow . You can make Gnus use the external Unix
46 decoder, such as uudecode."
47 :type '(choice (item :tag "internal" uudecode-decode-region)
48 (item :tag "external" uudecode-decode-region-external))
49 :group 'gnus-article-mime)
51 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
52 "*Function to binhex decode.
53 Internal function is done in elisp by default, therefore decoding may
54 appear to be horribly slow . You can make Gnus use the external Unix
55 decoder, such as hexbin."
56 :type '(choice (item :tag "internal" binhex-decode-region)
57 (item :tag "external" binhex-decode-region-external))
58 :group 'gnus-article-mime)
60 (defvar mm-uu-pgp-beginning-signature
61 "^-----BEGIN PGP SIGNATURE-----")
63 (defvar mm-uu-beginning-regexp nil)
65 (defvar mm-dissect-disposition "inline"
66 "The default disposition of uu parts.
67 This can be either \"inline\" or \"attachment\".")
69 (defvar mm-uu-type-alist
73 mm-uu-postscript-extract
76 "^begin[ \t]+[0-7][0-7][0-7][ \t]+"
81 "^:...............................................................$"
85 mm-uu-binhex-filename)
91 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
92 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
93 "^-+ \\(Start of \\)?Forwarded message"
94 "^-+ End \\(of \\)?forwarded message"
99 "^----gnatsweb-attachment----"
101 mm-uu-gnatsweb-extract)
103 "^-----BEGIN PGP SIGNED MESSAGE-----"
104 "^-----END PGP SIGNATURE-----"
105 mm-uu-pgp-signed-extract
109 "^-----BEGIN PGP MESSAGE-----"
110 "^-----END PGP MESSAGE-----"
111 mm-uu-pgp-encrypted-extract
115 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
116 "^-----END PGP PUBLIC KEY BLOCK-----"
117 mm-uu-pgp-key-extract
118 mm-uu-gpg-key-skip-to-last
121 (defcustom mm-uu-configure-list nil
122 "A list of mm-uu configuration.
123 To disable dissecting shar codes, for instance, add
124 `(shar . disabled)' to this list."
129 (cons 'item (car entry)))
131 (choice (item disabled))))
132 :group 'gnus-article-mime)
136 (defsubst mm-uu-type (entry)
139 (defsubst mm-uu-beginning-regexp (entry)
142 (defsubst mm-uu-end-regexp (entry)
145 (defsubst mm-uu-function-extract (entry)
148 (defsubst mm-uu-function-1 (entry)
151 (defsubst mm-uu-function-2 (entry)
154 (defun mm-uu-copy-to-buffer (from to)
155 "Copy the contents of the current buffer to a fresh buffer."
157 (let ((obuf (current-buffer)))
158 (set-buffer (generate-new-buffer " *mm-uu*"))
159 (insert-buffer-substring obuf from to)
162 (defun mm-uu-configure-p (key val)
163 (member (cons key val) mm-uu-configure-list))
165 (defun mm-uu-configure (&optional symbol value)
166 (if symbol (set-default symbol value))
167 (setq mm-uu-beginning-regexp nil)
168 (mapcar (lambda (entry)
169 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
171 (setq mm-uu-beginning-regexp
172 (concat mm-uu-beginning-regexp
173 (if mm-uu-beginning-regexp "\\|")
174 (mm-uu-beginning-regexp entry)))))
185 (defun mm-uu-uu-filename ()
186 (if (looking-at ".+")
188 (let ((nnheader-file-name-translation-alist
189 '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
190 (nnheader-translate-file-chars (match-string 0))))))
192 (defun mm-uu-binhex-filename ()
195 (binhex-decode-region start-point end-point t))))
197 (defun mm-uu-forward-test ()
199 (goto-char start-point)
201 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
203 (defun mm-uu-postscript-extract ()
204 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
205 '("application/postscript")))
207 (defun mm-uu-forward-extract ()
208 (mm-make-handle (mm-uu-copy-to-buffer
209 (progn (goto-char start-point) (forward-line) (point))
210 (progn (goto-char end-point) (forward-line -1) (point)))
211 '("message/rfc822" (charset . gnus-decoded))))
213 (defun mm-uu-uu-extract ()
214 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
215 (list (or (and file-name
216 (string-match "\\.[^\\.]+$"
218 (mailcap-extension-to-mime
219 (match-string 0 file-name)))
220 "application/octet-stream"))
222 (if (and file-name (not (equal file-name "")))
223 (list mm-dissect-disposition
224 (cons 'filename file-name)))))
226 (defun mm-uu-binhex-extract ()
227 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
228 (list (or (and file-name
229 (string-match "\\.[^\\.]+$" file-name)
230 (mailcap-extension-to-mime
231 (match-string 0 file-name)))
232 "application/octet-stream"))
234 (if (and file-name (not (equal file-name "")))
235 (list mm-dissect-disposition
236 (cons 'filename file-name)))))
238 (defun mm-uu-shar-extract ()
239 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
240 '("application/x-shar")))
242 (defun mm-uu-gnatsweb-extract ()
244 (goto-char start-point)
246 (narrow-to-region (point) end-point)
247 (mm-dissect-buffer t)))
249 (defun mm-uu-pgp-signed-test ()
252 (mml2015-clear-verify-function)
254 ((eq mm-verify-option 'never) nil)
255 ((eq mm-verify-option 'always) t)
256 ((eq mm-verify-option 'known) t)
257 (t (y-or-n-p "Verify pgp signed part?")))))
259 (defun mm-uu-pgp-signed-extract ()
260 (let ((buf (mm-uu-copy-to-buffer start-point end-point))
261 (mm-security-handle (list (format "multipart/signed"))))
262 (mm-set-handle-multipart-parameter
263 mm-security-handle 'protocol "application/pgp-signature")
264 (with-current-buffer buf
265 (when (mm-uu-pgp-signed-test)
266 (mml2015-clean-buffer)
267 (let ((coding-system-for-write (or gnus-newsgroup-charset
269 (funcall (mml2015-clear-verify-function))))
270 (goto-char (point-min))
271 (if (search-forward "\n\n" nil t)
272 (delete-region (point-min) (point)))
273 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
274 (delete-region (match-beginning 0) (point-max))))
275 (setcdr mm-security-handle
278 '("text/plain" (charset . gnus-decoded)))))
281 (defun mm-uu-pgp-encrypted-test ()
284 (mml2015-clear-decrypt-function)
286 ((eq mm-decrypt-option 'never) nil)
287 ((eq mm-decrypt-option 'always) t)
288 ((eq mm-decrypt-option 'known) t)
289 (t (y-or-n-p "Decrypt pgp encrypted part?")))))
291 (defun mm-uu-pgp-encrypted-extract ()
292 (let ((buf (mm-uu-copy-to-buffer start-point end-point))
293 (mm-security-handle (list (format "multipart/encrypted"))))
294 (mm-set-handle-multipart-parameter
295 mm-security-handle 'protocol "application/pgp-encrypted")
296 (if (mm-uu-pgp-encrypted-test)
297 (with-current-buffer buf
298 (mml2015-clean-buffer)
299 (funcall (mml2015-clear-decrypt-function))))
300 (setcdr mm-security-handle
303 '("text/plain" (charset . gnus-decoded)))))
306 (defun mm-uu-gpg-key-skip-to-last ()
307 (let ((point (point))
308 (end-regexp (mm-uu-end-regexp entry))
309 (beginning-regexp (mm-uu-beginning-regexp entry)))
310 (when (and end-regexp
311 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
312 (while (re-search-forward end-regexp nil t)
313 (skip-chars-forward " \t\n\r")
314 (if (looking-at beginning-regexp)
315 (setq point (match-end 0)))))
318 (defun mm-uu-pgp-key-extract ()
319 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
321 '("application/pgp-keys"))))
324 (defun mm-uu-dissect ()
325 "Dissect the current buffer and return a list of uu handles."
326 (let ((case-fold-search t)
327 text-start start-point end-point file-name result
328 text-plain-type entry func)
330 (goto-char (point-min))
334 ((search-forward "\n\n" nil t)
336 (t (goto-char (point-max))))
337 ;;; gnus-decoded is a fake charset, which means no further
339 (setq text-start (point)
340 text-plain-type '("text/plain" (charset . gnus-decoded)))
341 (while (re-search-forward mm-uu-beginning-regexp nil t)
342 (setq start-point (match-beginning 0))
343 (let ((alist mm-uu-type-alist)
344 (beginning-regexp (match-string 0)))
346 (if (string-match (mm-uu-beginning-regexp (car alist))
348 (setq entry (car alist))
350 (if (setq func (mm-uu-function-1 entry))
352 (forward-line);; in case of failure
353 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
354 (let ((end-regexp (mm-uu-end-regexp entry)))
356 (or (setq end-point (point-max)) t)
358 (re-search-forward end-regexp nil t)
360 (setq end-point (point)))))
361 (or (not (setq func (mm-uu-function-2 entry)))
363 (if (and (> start-point text-start)
365 (goto-char text-start)
366 (re-search-forward "." start-point t)))
368 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
372 (funcall (mm-uu-function-extract entry))
374 (goto-char (setq text-start end-point))))
376 (if (and (> (point-max) (1+ text-start))
378 (goto-char text-start)
379 (re-search-forward "." nil t)))
381 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
384 (setq result (cons "multipart/mixed" (nreverse result))))
389 ;;; mm-uu.el ends here