1 |
;;; mm-uu.el --- return uu stuff as mm handles |
;;; mm-uu.el --- Return uu stuff as mm handles |
2 |
;; Copyright (c) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. |
;; Copyright (c) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. |
3 |
|
|
4 |
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> |
;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> |
5 |
;; Keywords: postscript uudecode binhex shar forward news |
;; Keywords: postscript uudecode binhex shar forward gnatsweb pgp |
6 |
|
|
7 |
;; This file is part of GNU Emacs. |
;; This file is part of GNU Emacs. |
8 |
|
|
30 |
(require 'nnheader) |
(require 'nnheader) |
31 |
(require 'mm-decode) |
(require 'mm-decode) |
32 |
(require 'mailcap) |
(require 'mailcap) |
33 |
(require 'uudecode) |
(require 'mml2015) |
|
(require 'binhex) |
|
34 |
|
|
35 |
(defun mm-uu-copy-to-buffer (from to) |
(autoload 'uudecode-decode-region "uudecode") |
36 |
"Copy the contents of the current buffer to a fresh buffer. |
(autoload 'uudecode-decode-region-external "uudecode") |
37 |
Return that buffer." |
(autoload 'uudecode-decode-region-internal "uudecode") |
38 |
(save-excursion |
|
39 |
(let ((obuf (current-buffer))) |
(autoload 'binhex-decode-region "binhex") |
40 |
(set-buffer (generate-new-buffer " *mm-uu*")) |
(autoload 'binhex-decode-region-external "binhex") |
41 |
(insert-buffer-substring obuf from to) |
(autoload 'binhex-decode-region-internal "binhex") |
|
(current-buffer)))) |
|
|
|
|
|
;;; postscript |
|
42 |
|
|
43 |
(defconst mm-uu-postscript-begin-line "^%!PS-") |
(autoload 'yenc-decode-region "yenc") |
44 |
(defconst mm-uu-postscript-end-line "^%%EOF$") |
(autoload 'yenc-extract-filename "yenc") |
45 |
|
|
|
(defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+") |
|
|
(defconst mm-uu-uu-end-line "^end[ \t]*$") |
|
|
|
|
|
;; This is not the right place for this. uudecode.el should decide |
|
|
;; whether or not to use a program with a single interface, but I |
|
|
;; guess it's too late now. Also the default should depend on a test |
|
|
;; for the program. -- fx |
|
46 |
(defcustom mm-uu-decode-function 'uudecode-decode-region |
(defcustom mm-uu-decode-function 'uudecode-decode-region |
47 |
"*Function to uudecode. |
"*Function to uudecode. |
48 |
Internal function is done in Lisp by default, therefore decoding may |
Internal function is done in Lisp by default, therefore decoding may |
49 |
appear to be horribly slow. You can make Gnus use an external |
appear to be horribly slow. You can make Gnus use an external |
50 |
decoder, such as uudecode." |
decoder, such as uudecode." |
51 |
:type '(choice |
:type '(choice |
52 |
(function-item :tag "Internal" uudecode-decode-region) |
(function-item :tag "Auto detect" uudecode-decode-region) |
53 |
|
(function-item :tag "Internal" uudecode-decode-region-internal) |
54 |
(function-item :tag "External" uudecode-decode-region-external)) |
(function-item :tag "External" uudecode-decode-region-external)) |
55 |
:group 'gnus-article-mime) |
:group 'gnus-article-mime) |
56 |
|
|
|
(defconst mm-uu-binhex-begin-line |
|
|
"^:...............................................................$") |
|
|
(defconst mm-uu-binhex-end-line ":$") |
|
|
|
|
57 |
(defcustom mm-uu-binhex-decode-function 'binhex-decode-region |
(defcustom mm-uu-binhex-decode-function 'binhex-decode-region |
58 |
"*Function to binhex decode. |
"*Function to binhex decode. |
59 |
Internal function is done in Lisp by default, therefore decoding may |
Internal function is done in elisp by default, therefore decoding may |
60 |
appear to be horribly slow. You can make Gnus use an external |
appear to be horribly slow . You can make Gnus use the external Unix |
61 |
decoder, such as hexbin." |
decoder, such as hexbin." |
62 |
:type '(choice |
:type '(choice (function-item :tag "Auto detect" binhex-decode-region) |
63 |
(function-item :tag "Internal" binhex-decode-region) |
(function-item :tag "Internal" binhex-decode-region-internal) |
64 |
(function-item :tag "External" binhex-decode-region-external)) |
(function-item :tag "External" binhex-decode-region-external)) |
65 |
:group 'gnus-article-mime) |
:group 'gnus-article-mime) |
66 |
|
|
67 |
(defconst mm-uu-shar-begin-line "^#! */bin/sh") |
(defvar mm-uu-yenc-decode-function 'yenc-decode-region) |
|
(defconst mm-uu-shar-end-line "^exit 0\\|^$") |
|
68 |
|
|
69 |
;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and |
(defvar mm-uu-pgp-beginning-signature |
70 |
;;; Peter von der Ah\'e <pahe@daimi.au.dk> |
"^-----BEGIN PGP SIGNATURE-----") |
|
(defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") |
|
|
(defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message") |
|
|
|
|
|
(defvar mm-uu-begin-line nil) |
|
71 |
|
|
72 |
(defconst mm-uu-identifier-alist |
(defvar mm-uu-beginning-regexp nil) |
|
'((?% . postscript) (?b . uu) (?: . binhex) (?# . shar) |
|
|
(?- . forward))) |
|
73 |
|
|
74 |
(defvar mm-dissect-disposition "inline" |
(defvar mm-dissect-disposition "inline" |
75 |
"The default disposition of uu parts. |
"The default disposition of uu parts. |
76 |
This can be either \"inline\" or \"attachment\".") |
This can be either \"inline\" or \"attachment\".") |
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 |
|
|
199 |
(defun mm-uu-configure-p (key val) |
(defun mm-uu-configure-p (key val) |
200 |
(member (cons key val) mm-uu-configure-list)) |
(member (cons key val) mm-uu-configure-list)) |
201 |
|
|
202 |
(defun mm-uu-configure (&optional symbol value) |
(defun mm-uu-configure (&optional symbol value) |
203 |
(if symbol (set-default symbol value)) |
(if symbol (set-default symbol value)) |
204 |
(setq mm-uu-begin-line nil) |
(setq mm-uu-beginning-regexp nil) |
205 |
(mapcar (lambda (type) |
(mapcar (lambda (entry) |
206 |
(if (mm-uu-configure-p type 'disabled) |
(if (mm-uu-configure-p (mm-uu-type entry) 'disabled) |
207 |
nil |
nil |
208 |
(setq mm-uu-begin-line |
(setq mm-uu-beginning-regexp |
209 |
(concat mm-uu-begin-line |
(concat mm-uu-beginning-regexp |
210 |
(if mm-uu-begin-line "\\|") |
(if mm-uu-beginning-regexp "\\|") |
211 |
(symbol-value |
(mm-uu-beginning-regexp entry))))) |
212 |
(intern (concat "mm-uu-" (symbol-name type) |
mm-uu-type-alist)) |
|
"-begin-line"))))))) |
|
|
'(uu postscript binhex shar forward))) |
|
|
|
|
|
;; Needs to come after mm-uu-configure. |
|
|
(defcustom mm-uu-configure-list nil |
|
|
"Alist of mm-uu configurations to disable. |
|
|
To disable dissecting shar codes, for instance, add |
|
|
`(shar . disabled)' to this list." |
|
|
:type '(repeat (choice (const :tag "postscript" (postscript . disabled)) |
|
|
(const :tag "uu" (uu . disabled)) |
|
|
(const :tag "binhex" (binhex . disabled)) |
|
|
(const :tag "shar" (shar . disabled)) |
|
|
(const :tag "forward" (forward . disabled)))) |
|
|
:group 'gnus-article-mime |
|
|
:set 'mm-uu-configure) |
|
213 |
|
|
214 |
(mm-uu-configure) |
(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")))) |
431 |
|
|
432 |
;;;###autoload |
;;;###autoload |
433 |
(defun mm-uu-dissect () |
(defun mm-uu-dissect () |
434 |
"Dissect the current buffer and return a list of uu handles." |
"Dissect the current buffer and return a list of uu handles." |
435 |
(let (text-start start-char end-char |
(let ((case-fold-search t) |
436 |
type file-name end-line result text-plain-type |
text-start start-point end-point file-name result |
437 |
start-char-1 end-char-1 |
text-plain-type entry func) |
|
(case-fold-search t)) |
|
438 |
(save-excursion |
(save-excursion |
439 |
(save-restriction |
(goto-char (point-min)) |
440 |
(mail-narrow-to-head) |
(cond |
441 |
(goto-char (point-max))) |
((looking-at "\n") |
442 |
(forward-line) |
(forward-line)) |
443 |
|
((search-forward "\n\n" nil t) |
444 |
|
t) |
445 |
|
(t (goto-char (point-max)))) |
446 |
;;; gnus-decoded is a fake charset, which means no further |
;;; gnus-decoded is a fake charset, which means no further |
447 |
;;; decoding. |
;;; decoding. |
448 |
(setq text-start (point) |
(setq text-start (point) |
449 |
text-plain-type '("text/plain" (charset . gnus-decoded))) |
text-plain-type '("text/plain" (charset . gnus-decoded))) |
450 |
(while (re-search-forward mm-uu-begin-line nil t) |
(while (re-search-forward mm-uu-beginning-regexp nil t) |
451 |
(setq start-char (match-beginning 0)) |
(setq start-point (match-beginning 0)) |
452 |
(setq type (cdr (assq (aref (match-string 0) 0) |
(let ((alist mm-uu-type-alist) |
453 |
mm-uu-identifier-alist))) |
(beginning-regexp (match-string 0))) |
454 |
(setq file-name |
(while (not entry) |
455 |
(if (and (eq type 'uu) |
(if (string-match (mm-uu-beginning-regexp (car alist)) |
456 |
(looking-at "\\(.+\\)$")) |
beginning-regexp) |
457 |
(and (match-string 1) |
(setq entry (car alist)) |
458 |
(let ((nnheader-file-name-translation-alist |
(pop alist)))) |
459 |
'((?/ . ?,) (?\ . ?_) (?* . ?_) (?$ . ?_)))) |
(if (setq func (mm-uu-function-1 entry)) |
460 |
(nnheader-translate-file-chars (match-string 1)))))) |
(funcall func)) |
461 |
(forward-line);; in case of failure |
(forward-line);; in case of failure |
462 |
(setq start-char-1 (point)) |
(when (and (not (mm-uu-configure-p (mm-uu-type entry) 'disabled)) |
463 |
(setq end-line (symbol-value |
(let ((end-regexp (mm-uu-end-regexp entry))) |
464 |
(intern (concat "mm-uu-" (symbol-name type) |
(if (not end-regexp) |
465 |
"-end-line")))) |
(or (setq end-point (point-max)) t) |
466 |
(when (and (re-search-forward end-line nil t) |
(prog1 |
467 |
(not (eq (match-beginning 0) (match-end 0)))) |
(re-search-forward end-regexp nil t) |
468 |
(setq end-char-1 (match-beginning 0)) |
(forward-line) |
469 |
(forward-line) |
(setq end-point (point))))) |
470 |
(setq end-char (point)) |
(or (not (setq func (mm-uu-function-2 entry))) |
471 |
(when (cond |
(funcall func))) |
472 |
((eq type 'binhex) |
(if (and (> start-point text-start) |
473 |
(setq file-name |
(progn |
474 |
(ignore-errors |
(goto-char text-start) |
475 |
(binhex-decode-region start-char end-char t)))) |
(re-search-forward "." start-point t))) |
476 |
((eq type 'forward) |
(push |
477 |
(save-excursion |
(mm-make-handle (mm-uu-copy-to-buffer text-start start-point) |
478 |
(goto-char start-char-1) |
text-plain-type) |
479 |
(looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) |
result)) |
480 |
(t t)) |
(push |
481 |
(if (> start-char text-start) |
(funcall (mm-uu-function-extract entry)) |
482 |
(push |
result) |
483 |
(mm-make-handle (mm-uu-copy-to-buffer text-start start-char) |
(goto-char (setq text-start end-point)))) |
|
text-plain-type) |
|
|
result)) |
|
|
(push |
|
|
(cond |
|
|
((eq type 'postscript) |
|
|
(mm-make-handle (mm-uu-copy-to-buffer start-char end-char) |
|
|
'("application/postscript"))) |
|
|
((eq type 'forward) |
|
|
(mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1) |
|
|
'("message/rfc822" (charset . gnus-decoded)))) |
|
|
((eq type 'uu) |
|
|
(mm-make-handle (mm-uu-copy-to-buffer start-char end-char) |
|
|
(list (or (and file-name |
|
|
(string-match "\\.[^\\.]+$" |
|
|
file-name) |
|
|
(mailcap-extension-to-mime |
|
|
(match-string 0 file-name))) |
|
|
"application/octet-stream")) |
|
|
'x-uuencode nil |
|
|
(if (and file-name (not (equal file-name ""))) |
|
|
(list mm-dissect-disposition |
|
|
(cons 'filename file-name))))) |
|
|
((eq type 'binhex) |
|
|
(mm-make-handle (mm-uu-copy-to-buffer start-char end-char) |
|
|
(list (or (and file-name |
|
|
(string-match "\\.[^\\.]+$" file-name) |
|
|
(mailcap-extension-to-mime |
|
|
(match-string 0 file-name))) |
|
|
"application/octet-stream")) |
|
|
'x-binhex nil |
|
|
(if (and file-name (not (equal file-name ""))) |
|
|
(list mm-dissect-disposition |
|
|
(cons 'filename file-name))))) |
|
|
((eq type 'shar) |
|
|
(mm-make-handle (mm-uu-copy-to-buffer start-char end-char) |
|
|
'("application/x-shar")))) |
|
|
result) |
|
|
(setq text-start end-char)))) |
|
484 |
(when result |
(when result |
485 |
(if (> (point-max) (1+ text-start)) |
(if (and (> (point-max) (1+ text-start)) |
486 |
|
(save-excursion |
487 |
|
(goto-char text-start) |
488 |
|
(re-search-forward "." nil t))) |
489 |
(push |
(push |
490 |
(mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) |
(mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) |
491 |
text-plain-type) |
text-plain-type) |
493 |
(setq result (cons "multipart/mixed" (nreverse result)))) |
(setq result (cons "multipart/mixed" (nreverse result)))) |
494 |
result))) |
result))) |
495 |
|
|
|
;;;###autoload |
|
|
(defun mm-uu-test () |
|
|
"Check whether the current buffer contains uu stuff." |
|
|
(save-excursion |
|
|
(goto-char (point-min)) |
|
|
(let (type end-line result |
|
|
(case-fold-search t)) |
|
|
(while (and mm-uu-begin-line |
|
|
(not result) (re-search-forward mm-uu-begin-line nil t)) |
|
|
(forward-line) |
|
|
(setq type (cdr (assq (aref (match-string 0) 0) |
|
|
mm-uu-identifier-alist))) |
|
|
(setq end-line (symbol-value |
|
|
(intern (concat "mm-uu-" (symbol-name type) |
|
|
"-end-line")))) |
|
|
(if (and (re-search-forward end-line nil t) |
|
|
(not (eq (match-beginning 0) (match-end 0)))) |
|
|
(setq result t))) |
|
|
result))) |
|
|
|
|
496 |
(provide 'mm-uu) |
(provide 'mm-uu) |
497 |
|
|
498 |
;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c |
;;; arch-tag: 7db076bf-53db-4320-aa19-ca76a1d2ab2c |