Mercurial > emacs

comparison lisp/gnus/mm-uu.el @ 89971:cce1c0ee76ee

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Revision: miles@gnu.org--gnu-2004/emacs--unicode--0--patch-36 Merge from emacs--cvs-trunk--0, emacs--gnus--5.10, gnus--rel--5.10 Patches applied: * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523 Merge from emacs--gnus--5.10, gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-524 - miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-534 Update from CVS * miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0 tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1 Import from CVS branch gnus-5_10-branch * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2 Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4 Merge from gnus--rel--5.10 * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18 Update from CVS * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19 Remove autoconf-generated files from archive * miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20 Update from CVS
author Miles Bader <miles@gnu.org>
date Thu, 09 Sep 2004 09:36:36 +0000
parents 561b856c5b1f 55fd4f77387a
children e24e2e78deda
comparison
equal deleted inserted replaced
89970:a849e5779b8c 89971:cce1c0ee76ee
1 ;;; mm-uu.el --- return uu stuff as mm handles 1 ;;; mm-uu.el --- Return uu stuff as mm handles
2 ;; Copyright (c) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. 2 ;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
3 3
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> 4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5 ;; Keywords: postscript uudecode binhex shar forward news 5 ;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
8 8
9 ;; GNU Emacs is free software; you can redistribute it and/or modify 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 10 ;; it under the terms of the GNU General Public License as published by
28 (eval-when-compile (require 'cl)) 28 (eval-when-compile (require 'cl))
29 (require 'mail-parse) 29 (require 'mail-parse)
30 (require 'nnheader) 30 (require 'nnheader)
31 (require 'mm-decode) 31 (require 'mm-decode)
32 (require 'mailcap) 32 (require 'mailcap)
33 (require 'uudecode) 33 (require 'mml2015)
34 (require 'binhex) 34
35 35 (autoload 'uudecode-decode-region "uudecode")
36 (defun mm-uu-copy-to-buffer (from to) 36 (autoload 'uudecode-decode-region-external "uudecode")
37 "Copy the contents of the current buffer to a fresh buffer. 37 (autoload 'uudecode-decode-region-internal "uudecode")
38 Return that buffer." 38
39 (save-excursion 39 (autoload 'binhex-decode-region "binhex")
40 (let ((obuf (current-buffer))) 40 (autoload 'binhex-decode-region-external "binhex")
41 (set-buffer (generate-new-buffer " *mm-uu*")) 41 (autoload 'binhex-decode-region-internal "binhex")
42 (insert-buffer-substring obuf from to) 42
43 (current-buffer)))) 43 (autoload 'yenc-decode-region "yenc")
44 44 (autoload 'yenc-extract-filename "yenc")
45 ;;; postscript 45
46
47 (defconst mm-uu-postscript-begin-line "^%!PS-")
48 (defconst mm-uu-postscript-end-line "^%%EOF$")
49
50 (defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+")
51 (defconst mm-uu-uu-end-line "^end[ \t]*$")
52
53 ;; This is not the right place for this. uudecode.el should decide
54 ;; whether or not to use a program with a single interface, but I
55 ;; guess it's too late now. Also the default should depend on a test
56 ;; for the program. -- fx
57 (defcustom mm-uu-decode-function 'uudecode-decode-region 46 (defcustom mm-uu-decode-function 'uudecode-decode-region
58 "*Function to uudecode. 47 "*Function to uudecode.
59 Internal function is done in Lisp by default, therefore decoding may 48 Internal function is done in Lisp by default, therefore decoding may
60 appear to be horribly slow. You can make Gnus use an external 49 appear to be horribly slow. You can make Gnus use an external
61 decoder, such as uudecode." 50 decoder, such as uudecode."
62 :type '(choice 51 :type '(choice
63 (function-item :tag "Internal" uudecode-decode-region) 52 (function-item :tag "Auto detect" uudecode-decode-region)
53 (function-item :tag "Internal" uudecode-decode-region-internal)
64 (function-item :tag "External" uudecode-decode-region-external)) 54 (function-item :tag "External" uudecode-decode-region-external))
65 :group 'gnus-article-mime) 55 :group 'gnus-article-mime)
66 56
67 (defconst mm-uu-binhex-begin-line
68 "^:...............................................................$")
69 (defconst mm-uu-binhex-end-line ":$")
70
71 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region 57 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region
72 "*Function to binhex decode. 58 "*Function to binhex decode.
73 Internal function is done in Lisp by default, therefore decoding may 59 Internal function is done in elisp by default, therefore decoding may
74 appear to be horribly slow. You can make Gnus use an external 60 appear to be horribly slow . You can make Gnus use the external Unix
75 decoder, such as hexbin." 61 decoder, such as hexbin."
76 :type '(choice 62 :type '(choice (function-item :tag "Auto detect" binhex-decode-region)
77 (function-item :tag "Internal" binhex-decode-region) 63 (function-item :tag "Internal" binhex-decode-region-internal)
78 (function-item :tag "External" binhex-decode-region-external)) 64 (function-item :tag "External" binhex-decode-region-external))
79 :group 'gnus-article-mime) 65 :group 'gnus-article-mime)
80 66
81 (defconst mm-uu-shar-begin-line "^#! */bin/sh") 67 (defvar mm-uu-yenc-decode-function 'yenc-decode-region)
82 (defconst mm-uu-shar-end-line "^exit 0\\|^$") 68
83 69 (defvar mm-uu-pgp-beginning-signature
84 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and 70 "^-----BEGIN PGP SIGNATURE-----")
85 ;;; Peter von der Ah\'e <pahe@daimi.au.dk> 71
86 (defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") 72 (defvar mm-uu-beginning-regexp nil)
87 (defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message")
88
89 (defvar mm-uu-begin-line nil)
90
91 (defconst mm-uu-identifier-alist
92 '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar)
93 (?- . forward)))
94 73
95 (defvar mm-dissect-disposition "inline" 74 (defvar mm-dissect-disposition "inline"
96 "The default disposition of uu parts. 75 "The default disposition of uu parts.
97 This can be either \"inline\" or \"attachment\".") 76 This can be either \"inline\" or \"attachment\".")
98 77
78 (defvar mm-uu-emacs-sources-regexp "gnu\\.emacs\\.sources"
79 "The regexp of Emacs sources groups.")
80
81 (defcustom mm-uu-diff-groups-regexp "gnus\\.commits"
82 "*Regexp matching diff groups."
83 :type 'regexp
84 :group 'gnus-article-mime)
85
86 (defvar mm-uu-type-alist
87 '((postscript
88 "^%!PS-"
89 "^%%EOF$"
90 mm-uu-postscript-extract
91 nil)
92 (uu
93 "^begin[ \t]+0?[0-7][0-7][0-7][ \t]+"
94 "^end[ \t]*$"
95 mm-uu-uu-extract
96 mm-uu-uu-filename)
97 (binhex
98 "^:...............................................................$"
99 ":$"
100 mm-uu-binhex-extract
101 nil
102 mm-uu-binhex-filename)
103 (yenc
104 "^=ybegin.*size=[0-9]+.*name=.*$"
105 "^=yend.*size=[0-9]+"
106 mm-uu-yenc-extract
107 mm-uu-yenc-filename)
108 (shar
109 "^#! */bin/sh"
110 "^exit 0$"
111 mm-uu-shar-extract)
112 (forward
113 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and
114 ;;; Peter von der Ah\'e <pahe@daimi.au.dk>
115 "^-+ \\(Start of \\)?Forwarded message"
116 "^-+ End \\(of \\)?forwarded message"
117 mm-uu-forward-extract
118 nil
119 mm-uu-forward-test)
120 (gnatsweb
121 "^----gnatsweb-attachment----"
122 nil
123 mm-uu-gnatsweb-extract)
124 (pgp-signed
125 "^-----BEGIN PGP SIGNED MESSAGE-----"
126 "^-----END PGP SIGNATURE-----"
127 mm-uu-pgp-signed-extract
128 nil
129 nil)
130 (pgp-encrypted
131 "^-----BEGIN PGP MESSAGE-----"
132 "^-----END PGP MESSAGE-----"
133 mm-uu-pgp-encrypted-extract
134 nil
135 nil)
136 (pgp-key
137 "^-----BEGIN PGP PUBLIC KEY BLOCK-----"
138 "^-----END PGP PUBLIC KEY BLOCK-----"
139 mm-uu-pgp-key-extract
140 mm-uu-gpg-key-skip-to-last
141 nil)
142 (emacs-sources
143 "^;;;?[ \t]*[^ \t]+\\.el[ \t]*--"
144 "^;;;?[ \t]*\\([^ \t]+\\.el\\)[ \t]+ends here"
145 mm-uu-emacs-sources-extract
146 nil
147 mm-uu-emacs-sources-test)
148 (diff
149 "^Index: "
150 nil
151 mm-uu-diff-extract
152 nil
153 mm-uu-diff-test)))
154
155 (defcustom mm-uu-configure-list '((shar . disabled))
156 "A list of mm-uu configuration.
157 To disable dissecting shar codes, for instance, add
158 `(shar . disabled)' to this list."
159 :type 'alist
160 :options (mapcar (lambda (entry)
161 (list (car entry) '(const disabled)))
162 mm-uu-type-alist)
163 :group 'gnus-article-mime)
164
165 ;; functions
166
167 (defsubst mm-uu-type (entry)
168 (car entry))
169
170 (defsubst mm-uu-beginning-regexp (entry)
171 (nth 1 entry))
172
173 (defsubst mm-uu-end-regexp (entry)
174 (nth 2 entry))
175
176 (defsubst mm-uu-function-extract (entry)
177 (nth 3 entry))
178
179 (defsubst mm-uu-function-1 (entry)
180 (nth 4 entry))
181
182 (defsubst mm-uu-function-2 (entry)
183 (nth 5 entry))
184
185 (defun mm-uu-copy-to-buffer (&optional from to)
186 "Copy the contents of the current buffer to a fresh buffer.
187 Return that buffer."
188 (save-excursion
189 (let ((obuf (current-buffer))
190 (coding-system
191 ;; Might not exist in non-MULE XEmacs
192 (when (boundp 'buffer-file-coding-system)
193 buffer-file-coding-system)))
194 (set-buffer (generate-new-buffer " *mm-uu*"))
195 (setq buffer-file-coding-system coding-system)
196 (insert-buffer-substring obuf from to)
197 (current-buffer))))
198
99 (defun mm-uu-configure-p (key val) 199 (defun mm-uu-configure-p (key val)
100 (member (cons key val) mm-uu-configure-list)) 200 (member (cons key val) mm-uu-configure-list))
101 201
102 (defun mm-uu-configure (&optional symbol value) 202 (defun mm-uu-configure (&optional symbol value)
103 (if symbol (set-default symbol value)) 203 (if symbol (set-default symbol value))
104 (setq mm-uu-begin-line nil) 204 (setq mm-uu-beginning-regexp nil)
105 (mapcar (lambda (type) 205 (mapcar (lambda (entry)
106 (if (mm-uu-configure-p type 'disabled) 206 (if (mm-uu-configure-p (mm-uu-type entry) 'disabled)
107 nil 207 nil
108 (setq mm-uu-begin-line 208 (setq mm-uu-beginning-regexp
109 (concat mm-uu-begin-line 209 (concat mm-uu-beginning-regexp
110 (if mm-uu-begin-line "\\|") 210 (if mm-uu-beginning-regexp "\\|")
111 (symbol-value 211 (mm-uu-beginning-regexp entry)))))
112 (intern (concat "mm-uu-" (symbol-name type) 212 mm-uu-type-alist))
113 "-begin-line")))))))
114 '(uu postscript binhex shar forward)))
115
116 ;; Needs to come after mm-uu-configure.
117 (defcustom mm-uu-configure-list nil
118 "Alist of mm-uu configurations to disable.
119 To disable dissecting shar codes, for instance, add
120 `(shar . disabled)' to this list."
121 :type '(repeat (choice (const :tag "postscript" (postscript . disabled))
122 (const :tag "uu" (uu . disabled))
123 (const :tag "binhex" (binhex . disabled))
124 (const :tag "shar" (shar . disabled))
125 (const :tag "forward" (forward . disabled))))
126 :group 'gnus-article-mime
127 :set 'mm-uu-configure)
128 213
129 (mm-uu-configure) 214 (mm-uu-configure)
215
216 (eval-when-compile
217 (defvar file-name)
218 (defvar start-point)
219 (defvar end-point)
220 (defvar entry))
221
222 (defun mm-uu-uu-filename ()
223 (if (looking-at ".+")
224 (setq file-name
225 (let ((nnheader-file-name-translation-alist
226 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_))))
227 (nnheader-translate-file-chars (match-string 0))))))
228
229 (defun mm-uu-binhex-filename ()
230 (setq file-name
231 (ignore-errors
232 (binhex-decode-region start-point end-point t))))
233
234 (defun mm-uu-yenc-filename ()
235 (goto-char start-point)
236 (setq file-name
237 (ignore-errors
238 (yenc-extract-filename))))
239
240 (defun mm-uu-forward-test ()
241 (save-excursion
242 (goto-char start-point)
243 (forward-line)
244 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:")))
245
246 (defun mm-uu-postscript-extract ()
247 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
248 '("application/postscript")))
249
250 (defun mm-uu-emacs-sources-extract ()
251 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
252 '("application/emacs-lisp")
253 nil nil
254 (list mm-dissect-disposition
255 (cons 'filename file-name))))
256
257 (eval-when-compile
258 (defvar gnus-newsgroup-name))
259
260 (defun mm-uu-emacs-sources-test ()
261 (setq file-name (match-string 1))
262 (and gnus-newsgroup-name
263 mm-uu-emacs-sources-regexp
264 (string-match mm-uu-emacs-sources-regexp gnus-newsgroup-name)))
265
266 (defun mm-uu-diff-extract ()
267 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
268 '("text/x-patch")))
269
270 (defun mm-uu-diff-test ()
271 (and gnus-newsgroup-name
272 mm-uu-diff-groups-regexp
273 (string-match mm-uu-diff-groups-regexp gnus-newsgroup-name)))
274
275 (defun mm-uu-forward-extract ()
276 (mm-make-handle (mm-uu-copy-to-buffer
277 (progn (goto-char start-point) (forward-line) (point))
278 (progn (goto-char end-point) (forward-line -1) (point)))
279 '("message/rfc822" (charset . gnus-decoded))))
280
281 (defun mm-uu-uu-extract ()
282 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
283 (list (or (and file-name
284 (string-match "\\.[^\\.]+$"
285 file-name)
286 (mailcap-extension-to-mime
287 (match-string 0 file-name)))
288 "application/octet-stream"))
289 'x-uuencode nil
290 (if (and file-name (not (equal file-name "")))
291 (list mm-dissect-disposition
292 (cons 'filename file-name)))))
293
294 (defun mm-uu-binhex-extract ()
295 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
296 (list (or (and file-name
297 (string-match "\\.[^\\.]+$" file-name)
298 (mailcap-extension-to-mime
299 (match-string 0 file-name)))
300 "application/octet-stream"))
301 'x-binhex nil
302 (if (and file-name (not (equal file-name "")))
303 (list mm-dissect-disposition
304 (cons 'filename file-name)))))
305
306 (defun mm-uu-yenc-extract ()
307 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
308 (list (or (and file-name
309 (string-match "\\.[^\\.]+$" file-name)
310 (mailcap-extension-to-mime
311 (match-string 0 file-name)))
312 "application/octet-stream"))
313 'x-yenc nil
314 (if (and file-name (not (equal file-name "")))
315 (list mm-dissect-disposition
316 (cons 'filename file-name)))))
317
318
319 (defun mm-uu-shar-extract ()
320 (mm-make-handle (mm-uu-copy-to-buffer start-point end-point)
321 '("application/x-shar")))
322
323 (defun mm-uu-gnatsweb-extract ()
324 (save-restriction
325 (goto-char start-point)
326 (forward-line)
327 (narrow-to-region (point) end-point)
328 (mm-dissect-buffer t)))
329
330 (defun mm-uu-pgp-signed-test (&rest rest)
331 (and
332 mml2015-use
333 (mml2015-clear-verify-function)
334 (cond
335 ((eq mm-verify-option 'never) nil)
336 ((eq mm-verify-option 'always) t)
337 ((eq mm-verify-option 'known) t)
338 (t (y-or-n-p "Verify pgp signed part? ")))))
339
340 (eval-when-compile
341 (defvar gnus-newsgroup-charset))
342
343 (defun mm-uu-pgp-signed-extract-1 (handles ctl)
344 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
345 (with-current-buffer buf
346 (if (mm-uu-pgp-signed-test)
347 (progn
348 (mml2015-clean-buffer)
349 (let ((coding-system-for-write (or gnus-newsgroup-charset
350 'iso-8859-1)))
351 (funcall (mml2015-clear-verify-function))))
352 (when (and mml2015-use (null (mml2015-clear-verify-function)))
353 (mm-set-handle-multipart-parameter
354 mm-security-handle 'gnus-details
355 (format "Clear verification not supported by `%s'.\n" mml2015-use))))
356 (goto-char (point-min))
357 (if (search-forward "\n\n" nil t)
358 (delete-region (point-min) (point)))
359 (if (re-search-forward mm-uu-pgp-beginning-signature nil t)
360 (delete-region (match-beginning 0) (point-max)))
361 (goto-char (point-min))
362 (while (re-search-forward "^- " nil t)
363 (replace-match "" t t)
364 (forward-line 1)))
365 (list (mm-make-handle buf '("text/plain" (charset . gnus-decoded))))))
366
367 (defun mm-uu-pgp-signed-extract ()
368 (let ((mm-security-handle (list (format "multipart/signed"))))
369 (mm-set-handle-multipart-parameter
370 mm-security-handle 'protocol "application/x-gnus-pgp-signature")
371 (save-restriction
372 (narrow-to-region start-point end-point)
373 (add-text-properties 0 (length (car mm-security-handle))
374 (list 'buffer (mm-uu-copy-to-buffer))
375 (car mm-security-handle))
376 (setcdr mm-security-handle
377 (mm-uu-pgp-signed-extract-1 nil
378 mm-security-handle)))
379 mm-security-handle))
380
381 (defun mm-uu-pgp-encrypted-test (&rest rest)
382 (and
383 mml2015-use
384 (mml2015-clear-decrypt-function)
385 (cond
386 ((eq mm-decrypt-option 'never) nil)
387 ((eq mm-decrypt-option 'always) t)
388 ((eq mm-decrypt-option 'known) t)
389 (t (y-or-n-p "Decrypt pgp encrypted part? ")))))
390
391 (defun mm-uu-pgp-encrypted-extract-1 (handles ctl)
392 (let ((buf (mm-uu-copy-to-buffer (point-min) (point-max))))
393 (if (mm-uu-pgp-encrypted-test)
394 (with-current-buffer buf
395 (mml2015-clean-buffer)
396 (funcall (mml2015-clear-decrypt-function))))
397 (list
398 (mm-make-handle buf
399 '("text/plain" (charset . gnus-decoded))))))
400
401 (defun mm-uu-pgp-encrypted-extract ()
402 (let ((mm-security-handle (list (format "multipart/encrypted"))))
403 (mm-set-handle-multipart-parameter
404 mm-security-handle 'protocol "application/x-gnus-pgp-encrypted")
405 (save-restriction
406 (narrow-to-region start-point end-point)
407 (add-text-properties 0 (length (car mm-security-handle))
408 (list 'buffer (mm-uu-copy-to-buffer))
409 (car mm-security-handle))
410 (setcdr mm-security-handle
411 (mm-uu-pgp-encrypted-extract-1 nil
412 mm-security-handle)))
413 mm-security-handle))
414
415 (defun mm-uu-gpg-key-skip-to-last ()
416 (let ((point (point))
417 (end-regexp (mm-uu-end-regexp entry))
418 (beginning-regexp (mm-uu-beginning-regexp entry)))
419 (when (and end-regexp
420 (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)))
421 (while (re-search-forward end-regexp nil t)
422 (skip-chars-forward " \t\n\r")
423 (if (looking-at beginning-regexp)
424 (setq point (match-end 0)))))
425 (goto-char point)))
426
427 (defun mm-uu-pgp-key-extract ()
428 (let ((buf (mm-uu-copy-to-buffer start-point end-point)))
429 (mm-make-handle buf
430 '("application/pgp-keys"))))
130 431
131 ;;;###autoload 432 ;;;###autoload
132 (defun mm-uu-dissect () 433 (defun mm-uu-dissect ()
133 "Dissect the current buffer and return a list of uu handles." 434 "Dissect the current buffer and return a list of uu handles."
134 (let (text-start start-char end-char 435 (let ((case-fold-search t)
135 type file-name end-line result text-plain-type 436 text-start start-point end-point file-name result
136 start-char-1 end-char-1 437 text-plain-type entry func)
137 (case-fold-search t))
138 (save-excursion 438 (save-excursion
139 (save-restriction 439 (goto-char (point-min))
140 (mail-narrow-to-head) 440 (cond
141 (goto-char (point-max))) 441 ((looking-at "\n")
142 (forward-line) 442 (forward-line))
443 ((search-forward "\n\n" nil t)
444 t)
445 (t (goto-char (point-max))))
143 ;;; gnus-decoded is a fake charset, which means no further 446 ;;; gnus-decoded is a fake charset, which means no further
144 ;;; decoding. 447 ;;; decoding.
145 (setq text-start (point) 448 (setq text-start (point)
146 text-plain-type '("text/plain" (charset . gnus-decoded))) 449 text-plain-type '("text/plain" (charset . gnus-decoded)))
147 (while (re-search-forward mm-uu-begin-line nil t) 450 (while (re-search-forward mm-uu-beginning-regexp nil t)
148 (setq start-char (match-beginning 0)) 451 (setq start-point (match-beginning 0))
149 (setq type (cdr (assq (aref (match-string 0) 0) 452 (let ((alist mm-uu-type-alist)
150 mm-uu-identifier-alist))) 453 (beginning-regexp (match-string 0)))
151 (setq file-name 454 (while (not entry)
152 (if (and (eq type 'uu) 455 (if (string-match (mm-uu-beginning-regexp (car alist))
153 (looking-at "\\(.+\\)$")) 456 beginning-regexp)
154 (and (match-string 1) 457 (setq entry (car alist))
155 (let ((nnheader-file-name-translation-alist 458 (pop alist))))
156 '((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) 459 (if (setq func (mm-uu-function-1 entry))
157 (nnheader-translate-file-chars (match-string 1)))))) 460 (funcall func))
158 (forward-line);; in case of failure 461 (forward-line);; in case of failure
159 (setq start-char-1 (point)) 462 (when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled))
160 (setq end-line (symbol-value 463 (let ((end-regexp (mm-uu-end-regexp entry)))
161 (intern (concat "mm-uu-" (symbol-name type) 464 (if (not end-regexp)
162 "-end-line")))) 465 (or (setq end-point (point-max)) t)
163 (when (and (re-search-forward end-line nil t) 466 (prog1
164 (not (eq (match-beginning 0) (match-end 0)))) 467 (re-search-forward end-regexp nil t)
165 (setq end-char-1 (match-beginning 0)) 468 (forward-line)
166 (forward-line) 469 (setq end-point (point)))))
167 (setq end-char (point)) 470 (or (not (setq func (mm-uu-function-2 entry)))
168 (when (cond 471 (funcall func)))
169 ((eq type 'binhex) 472 (if (and (> start-point text-start)
170 (setq file-name 473 (progn
171 (ignore-errors 474 (goto-char text-start)
172 (binhex-decode-region start-char end-char t)))) 475 (re-search-forward "." start-point t)))
173 ((eq type 'forward) 476 (push
174 (save-excursion 477 (mm-make-handle (mm-uu-copy-to-buffer text-start start-point)
175 (goto-char start-char-1) 478 text-plain-type)
176 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) 479 result))
177 (t t)) 480 (push
178 (if (> start-char text-start) 481 (funcall (mm-uu-function-extract entry))
179 (push 482 result)
180 (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) 483 (goto-char (setq text-start end-point))))
181 text-plain-type)
182 result))
183 (push
184 (cond
185 ((eq type 'postscript)
186 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
187 '("application/postscript")))
188 ((eq type 'forward)
189 (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1)
190 '("message/rfc822" (charset . gnus-decoded))))
191 ((eq type 'uu)
192 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
193 (list (or (and file-name
194 (string-match "\\.[^\\.]+$"
195 file-name)
196 (mailcap-extension-to-mime
197 (match-string 0 file-name)))
198 "application/octet-stream"))
199 'x-uuencode nil
200 (if (and file-name (not (equal file-name "")))
201 (list mm-dissect-disposition
202 (cons 'filename file-name)))))
203 ((eq type 'binhex)
204 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
205 (list (or (and file-name
206 (string-match "\\.[^\\.]+$" file-name)
207 (mailcap-extension-to-mime
208 (match-string 0 file-name)))
209 "application/octet-stream"))
210 'x-binhex nil
211 (if (and file-name (not (equal file-name "")))
212 (list mm-dissect-disposition
213 (cons 'filename file-name)))))
214 ((eq type 'shar)
215 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char)
216 '("application/x-shar"))))
217 result)
218 (setq text-start end-char))))
219 (when result 484 (when result
220 (if (> (point-max) (1+ text-start)) 485 (if (and (> (point-max) (1+ text-start))
486 (save-excursion
487 (goto-char text-start)
488 (re-search-forward "." nil t)))
221 (push 489 (push
222 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) 490 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max))
223 text-plain-type) 491 text-plain-type)
224 result)) 492 result))
225 (setq result (cons "multipart/mixed" (nreverse result)))) 493 (setq result (cons "multipart/mixed" (nreverse result))))
226 result))) 494 result)))
227 495
228 ;;;###autoload
229 (defun mm-uu-test ()
230 "Check whether the current buffer contains uu stuff."
231 (save-excursion
232 (goto-char (point-min))
233 (let (type end-line result
234 (case-fold-search t))
235 (while (and mm-uu-begin-line
236 (not result) (re-search-forward mm-uu-begin-line nil t))
237 (forward-line)
238 (setq type (cdr (assq (aref (match-string 0) 0)
239 mm-uu-identifier-alist)))
240 (setq end-line (symbol-value
241 (intern (concat "mm-uu-" (symbol-name type)
242 "-end-line"))))
243 (if (and (re-search-forward end-line nil t)
244 (not (eq (match-beginning 0) (match-end 0))))
245 (setq result t)))
246 result)))
247
248 (provide 'mm-uu) 496 (provide 'mm-uu)
249 497
250 ;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c 498 ;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c
251 ;;; mm-uu.el ends here 499 ;;; mm-uu.el ends here