1 ;;; mm-uu.el -- Return uu stuff 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))
38 ;; This is not the right place for this. uudecode.el should decide
39 ;; whether or not to use a program with a single interface, but I
40 ;; guess it's too late now. Also the default should depend on a test
41 ;; for the program. -- fx
42 (defcustom mm-uu-decode-function 'uudecode-decode-region
43 "*Function to uudecode.
44 Internal function is done in Lisp by default, therefore decoding may
45 appear to be horribly slow. You can make Gnus use an external
46 decoder, such as uudecode."
48 (function-item :tag "Internal" uudecode-decode-region)
49 (function-item :tag "External" uudecode-decode-region-external))
50 :group 'gnus-article-mime)
52 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
53 "*Function to binhex decode.
54 Internal function is done in elisp by default, therefore decoding may
55 appear to be horribly slow . You can make Gnus use the external Unix
56 decoder, such as hexbin."
57 :type '(choice (item :tag "internal" binhex-decode-region)
58 (item :tag "external" binhex-decode-region-external))
59 :group 'gnus-article-mime)
61 (defvar mm-uu-pgp-beginning-signature
62 "^-----BEGIN PGP SIGNATURE-----")
64 (defvar mm-uu-beginning-regexp nil)
66 (defvar mm-dissect-disposition "inline"
67 "The default disposition of uu parts.
68 This can be either \"inline\" or \"attachment\".")
70 (defvar mm-uu-type-alist
74 mm-uu-postscript-extract
77 "^begin[ \t]+[0-7][0-7][0-7][ \t]+"
82 "^:...............................................................$"
86 mm-uu-binhex-filename)
92 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
93 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
94 "^-+ \\(Start of \\)?Forwarded message"
95 "^-+ End \\(of \\)?forwarded message"
100 "^----gnatsweb-attachment----"
102 mm-uu-gnatsweb-extract)
104 "^-----BEGIN PGP SIGNED MESSAGE-----"
105 "^-----END PGP SIGNATURE-----"
106 mm-uu-pgp-signed-extract
110 "^-----BEGIN PGP MESSAGE-----"
111 "^-----END PGP MESSAGE-----"
112 mm-uu-pgp-encrypted-extract
116 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
117 "^-----END PGP PUBLIC KEY BLOCK-----"
118 mm-uu-pgp-key-extract
119 mm-uu-gpg-key-skip-to-last
122 (defcustom mm-uu-configure-list nil
123 "A list of mm-uu configuration.
124 To disable dissecting shar codes, for instance, add
125 `(shar . disabled)' to this list."
130 (cons 'item (car entry)))
132 (choice (item disabled))))
133 :group 'gnus-article-mime)
137 (defsubst mm-uu-type (entry)
140 (defsubst mm-uu-beginning-regexp (entry)
143 (defsubst mm-uu-end-regexp (entry)
146 (defsubst mm-uu-function-extract (entry)
149 (defsubst mm-uu-function-1 (entry)
152 (defsubst mm-uu-function-2 (entry)
155 (defun mm-uu-copy-to-buffer (&optional from to)
156 "Copy the contents of the current buffer to a fresh buffer.
159 (let ((obuf (current-buffer)))
160 (set-buffer (generate-new-buffer " *mm-uu*"))
161 (insert-buffer-substring obuf from to)
164 (defun mm-uu-configure-p (key val)
165 (member (cons key val) mm-uu-configure-list))
167 (defun mm-uu-configure (&optional symbol value)
168 (if symbol (set-default symbol value))
169 (setq mm-uu-beginning-regexp nil)
170 (mapcar (lambda (entry)
171 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
173 (setq mm-uu-beginning-regexp
174 (concat mm-uu-beginning-regexp
175 (if mm-uu-beginning-regexp "\\|")
176 (mm-uu-beginning-regexp entry)))))
187 (defun mm-uu-uu-filename ()
188 (if (looking-at ".+")
190 (let ((nnheader-file-name-translation-alist
191 '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_))))
192 (nnheader-translate-file-chars (match-string 0))))))
194 (defun mm-uu-binhex-filename ()
197 (binhex-decode-region start-point end-point t))))
199 (defun mm-uu-forward-test ()
201 (goto-char start-point)
203 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
205 (defun mm-uu-postscript-extract ()
206 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
207 '("application/postscript")))
209 (defun mm-uu-forward-extract ()
210 (mm-make-handle (mm-uu-copy-to-buffer
211 (progn (goto-char start-point) (forward-line) (point))
212 (progn (goto-char end-point) (forward-line -1) (point)))
213 '("message/rfc822" (charset . gnus-decoded))))
215 (defun mm-uu-uu-extract ()
216 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
217 (list (or (and file-name
218 (string-match "\\.[^\\.]+$"
220 (mailcap-extension-to-mime
221 (match-string 0 file-name)))
222 "application/octet-stream"))
224 (if (and file-name (not (equal file-name "")))
225 (list mm-dissect-disposition
226 (cons 'filename file-name)))))
228 (defun mm-uu-binhex-extract ()
229 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
230 (list (or (and file-name
231 (string-match "\\.[^\\.]+$" file-name)
232 (mailcap-extension-to-mime
233 (match-string 0 file-name)))
234 "application/octet-stream"))
236 (if (and file-name (not (equal file-name "")))
237 (list mm-dissect-disposition
238 (cons 'filename file-name)))))
240 (defun mm-uu-shar-extract ()
241 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
242 '("application/x-shar")))
244 (defun mm-uu-gnatsweb-extract ()
246 (goto-char start-point)
248 (narrow-to-region (point) end-point)
249 (mm-dissect-buffer t)))
251 (defun mm-uu-pgp-signed-test (&rest rest)
254 (mml2015-clear-verify-function)
256 ((eq mm-verify-option 'never) nil)
257 ((eq mm-verify-option 'always) t)
258 ((eq mm-verify-option 'known) t)
259 (t (y-or-n-p "Verify pgp signed part?")))))
261 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
262 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
263 (with-current-buffer buf
264 (if (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 (when (and mml2015-use (null (mml2015-clear-verify-function)))
271 (mm-set-handle-multipart-parameter
272 mm-security-handle 'gnus-details
273 (format "Clear verification not supported by `%s'.\n" mml2015-use))))
274 (goto-char (point-min))
275 (if (search-forward "\n\n" nil t)
276 (delete-region (point-min) (point)))
277 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
278 (delete-region (match-beginning 0) (point-max))))
281 '("text/plain" (charset . gnus-decoded))))))
283 (defun mm-uu-pgp-signed-extract ()
284 (let ((mm-security-handle (list (format "multipart/signed"))))
285 (mm-set-handle-multipart-parameter
286 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
288 (narrow-to-region start-point end-point)
289 (add-text-properties 0 (length (car mm-security-handle))
290 (list 'buffer (mm-uu-copy-to-buffer))
291 (car mm-security-handle))
292 (setcdr mm-security-handle
293 (mm-uu-pgp-signed-extract-1 nil
294 mm-security-handle)))
297 (defun mm-uu-pgp-encrypted-test (&rest rest)
300 (mml2015-clear-decrypt-function)
302 ((eq mm-decrypt-option 'never) nil)
303 ((eq mm-decrypt-option 'always) t)
304 ((eq mm-decrypt-option 'known) t)
305 (t (y-or-n-p "Decrypt pgp encrypted part?")))))
307 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
308 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
309 (if (mm-uu-pgp-encrypted-test)
310 (with-current-buffer buf
311 (mml2015-clean-buffer)
312 (funcall (mml2015-clear-decrypt-function))))
315 '("text/plain" (charset . gnus-decoded))))))
317 (defun mm-uu-pgp-encrypted-extract ()
318 (let ((mm-security-handle (list (format "multipart/encrypted"))))
319 (mm-set-handle-multipart-parameter
320 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
322 (narrow-to-region start-point end-point)
323 (add-text-properties 0 (length (car mm-security-handle))
324 (list 'buffer (mm-uu-copy-to-buffer))
325 (car mm-security-handle))
326 (setcdr mm-security-handle
327 (mm-uu-pgp-encrypted-extract-1 nil
328 mm-security-handle)))
331 (defun mm-uu-gpg-key-skip-to-last ()
332 (let ((point (point))
333 (end-regexp (mm-uu-end-regexp entry))
334 (beginning-regexp (mm-uu-beginning-regexp entry)))
335 (when (and end-regexp
336 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
337 (while (re-search-forward end-regexp nil t)
338 (skip-chars-forward " \t\n\r")
339 (if (looking-at beginning-regexp)
340 (setq point (match-end 0)))))
343 (defun mm-uu-pgp-key-extract ()
344 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
346 '("application/pgp-keys"))))
349 (defun mm-uu-dissect ()
350 "Dissect the current buffer and return a list of uu handles."
351 (let ((case-fold-search t)
352 text-start start-point end-point file-name result
353 text-plain-type entry func)
355 (goto-char (point-min))
359 ((search-forward "\n\n" nil t)
361 (t (goto-char (point-max))))
362 ;;; gnus-decoded is a fake charset, which means no further
364 (setq text-start (point)
365 text-plain-type '("text/plain" (charset . gnus-decoded)))
366 (while (re-search-forward mm-uu-beginning-regexp nil t)
367 (setq start-point (match-beginning 0))
368 (let ((alist mm-uu-type-alist)
369 (beginning-regexp (match-string 0)))
371 (if (string-match (mm-uu-beginning-regexp (car alist))
373 (setq entry (car alist))
375 (if (setq func (mm-uu-function-1 entry))
377 (forward-line);; in case of failure
378 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
379 (let ((end-regexp (mm-uu-end-regexp entry)))
381 (or (setq end-point (point-max)) t)
383 (re-search-forward end-regexp nil t)
385 (setq end-point (point)))))
386 (or (not (setq func (mm-uu-function-2 entry)))
388 (if (and (> start-point text-start)
390 (goto-char text-start)
391 (re-search-forward "." start-point t)))
393 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
397 (funcall (mm-uu-function-extract entry))
399 (goto-char (setq text-start end-point))))
401 (if (and (> (point-max) (1+ text-start))
403 (goto-char text-start)
404 (re-search-forward "." nil t)))
406 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
409 (setq result (cons "multipart/mixed" (nreverse result))))
414 ;;; mm-uu.el ends here