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))
33 (require 'gnus-mailcap)
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-begin-signature
61 "^-----BEGIN PGP SIGNATURE-----")
63 (defvar mm-uu-begin-line 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
107 mm-uu-pgp-signed-test)
109 "^-----BEGIN PGP MESSAGE-----"
110 "^-----END PGP MESSAGE-----"
111 mm-uu-pgp-encrypted-extract
113 mm-uu-pgp-encrypted-test)
115 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
116 "^-----END PGP PUBLIC KEY BLOCK-----"
117 mm-uu-pgp-key-extract
119 mm-uu-pgp-key-test)))
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-begin-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-begin-line nil)
168 (mapcar (lambda (entry)
169 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
171 (setq mm-uu-begin-line
172 (concat mm-uu-begin-line
173 (if mm-uu-begin-line "\\|")
174 (mm-uu-begin-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 (or (memq 'signed gnus-article-wash-types)
261 (push 'signed gnus-article-wash-types))
262 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
263 (with-current-buffer buf
265 (funcall (mml2015-clear-verify-function))
267 (unless (y-or-n-p (format "%s, continue?" err))
269 (error "Verify failure."))))
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-begin-signature nil t)
274 (delete-region (match-beginning 0) (point-max))))
276 '("text/plain" (charset . gnus-decoded)))))
278 (defun mm-uu-pgp-encrypted-test ()
281 (mml2015-clear-decrypt-function)
283 ((eq mm-decrypt-option 'never) nil)
284 ((eq mm-decrypt-option 'always) t)
285 ((eq mm-decrypt-option 'known) t)
286 (t (y-or-n-p "Decrypt pgp encrypted part?")))))
288 (defun mm-uu-pgp-encrypted-extract ()
289 (or (memq 'encrypted gnus-article-wash-types)
290 (push 'encrypted gnus-article-wash-types))
291 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
292 (with-current-buffer buf
294 (funcall (mml2015-clear-decrypt-function))
296 (unless (y-or-n-p (format "%s, continue?" err))
298 (error "Decrypt failure.")))))
300 '("text/plain" (charset . gnus-decoded)))))
302 (defun mm-uu-pgp-key-test ()
305 (mml2015-clear-snarf-function)
307 ((eq mm-snarf-option 'never) nil)
308 ((eq mm-snarf-option 'always) t)
309 ((eq mm-snarf-option 'known) t)
310 (t (y-or-n-p "Snarf pgp signed part?")))))
312 (defun mm-uu-pgp-key-extract ()
313 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
314 (with-current-buffer buf
315 (funcall (mml2015-clear-snarf-function)))
317 '("application/x-pgp-key"))))
320 (defun mm-uu-dissect ()
321 "Dissect the current buffer and return a list of uu handles."
322 (let ((case-fold-search t)
323 text-start start-point end-point file-name result
324 text-plain-type entry func)
326 (goto-char (point-min))
330 ((search-forward "\n\n" nil t)
332 (t (goto-char (point-max))))
333 ;;; gnus-decoded is a fake charset, which means no further
335 (setq text-start (point)
336 text-plain-type '("text/plain" (charset . gnus-decoded)))
337 (while (re-search-forward mm-uu-begin-line nil t)
338 (setq start-point (match-beginning 0))
339 (let ((alist mm-uu-type-alist)
340 (begin-line (match-string 0)))
342 (if (string-match (mm-uu-begin-regexp (car alist)) begin-line)
343 (setq entry (car alist))
345 (if (setq func (mm-uu-function-1 entry))
347 (forward-line);; in case of failure
348 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
349 (let ((end-line (mm-uu-end-regexp entry)))
351 (or (setq end-point (point-max)) t)
353 (re-search-forward end-line nil t)
355 (setq end-point (point)))))
356 (or (not (setq func (mm-uu-function-2 entry)))
358 (if (and (> start-point text-start)
360 (goto-char text-start)
361 (re-search-forward "." start-point t)))
363 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
367 (funcall (mm-uu-function-extract entry))
369 (goto-char (setq text-start end-point))))
371 (if (and (> (point-max) (1+ text-start))
373 (goto-char text-start)
374 (re-search-forward "." nil t)))
376 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
379 (setq result (cons "multipart/mixed" (nreverse result))))
384 ;;; mm-uu.el ends here