Mercurial > emacs
comparison lisp/gnus/mm-uu.el @ 31717:6b20b7e85e3c
*** empty log message ***
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Tue, 19 Sep 2000 13:40:08 +0000 |
parents | |
children | 5d37eed2a6e2 |
comparison
equal
deleted
inserted
replaced
31716:9968f55ad26e | 31717:6b20b7e85e3c |
---|---|
1 ;;; mm-uu.el -- Return uu stuffs as mm handles | |
2 ;; Copyright (c) 1998, 1999, 2000 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> | |
5 ;; Keywords: postscript uudecode binhex shar forward news | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
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) | |
12 ;; any later version. | |
13 ;; | |
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. | |
18 | |
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. | |
23 | |
24 ;;; Commentary: | |
25 | |
26 | |
27 ;;; Code: | |
28 | |
29 (eval-when-compile (require 'cl)) | |
30 (require 'mail-parse) | |
31 (require 'nnheader) | |
32 (require 'mm-decode) | |
33 (require 'mailcap) | |
34 | |
35 (eval-and-compile | |
36 (autoload 'binhex-decode-region "binhex") | |
37 (autoload 'binhex-decode-region-external "binhex") | |
38 (autoload 'uudecode-decode-region "uudecode") | |
39 (autoload 'uudecode-decode-region-external "uudecode")) | |
40 | |
41 (defun mm-uu-copy-to-buffer (from to) | |
42 "Copy the contents of the current buffer to a fresh buffer." | |
43 (save-excursion | |
44 (let ((obuf (current-buffer))) | |
45 (set-buffer (generate-new-buffer " *mm-uu*")) | |
46 (insert-buffer-substring obuf from to) | |
47 (current-buffer)))) | |
48 | |
49 ;;; postscript | |
50 | |
51 (defconst mm-uu-postscript-begin-line "^%!PS-") | |
52 (defconst mm-uu-postscript-end-line "^%%EOF$") | |
53 | |
54 (defconst mm-uu-uu-begin-line "^begin[ \t]+[0-7][0-7][0-7][ \t]+") | |
55 (defconst mm-uu-uu-end-line "^end[ \t]*$") | |
56 | |
57 (defcustom mm-uu-decode-function 'uudecode-decode-region | |
58 "*Function to uudecode. | |
59 Internal function is done in elisp by default, therefore decoding may | |
60 appear to be horribly slow . You can make Gnus use the external Unix | |
61 decoder, such as uudecode." | |
62 :type '(choice (item :tag "internal" uudecode-decode-region) | |
63 (item :tag "external" uudecode-decode-region-external)) | |
64 :group 'gnus-article-mime) | |
65 | |
66 (defconst mm-uu-binhex-begin-line | |
67 "^:...............................................................$") | |
68 (defconst mm-uu-binhex-end-line ":$") | |
69 | |
70 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region | |
71 "*Function to binhex decode. | |
72 Internal function is done in elisp by default, therefore decoding may | |
73 appear to be horribly slow . You can make Gnus use the external Unix | |
74 decoder, such as hexbin." | |
75 :type '(choice (item :tag "internal" binhex-decode-region) | |
76 (item :tag "external" binhex-decode-region-external)) | |
77 :group 'gnus-article-mime) | |
78 | |
79 (defconst mm-uu-shar-begin-line "^#! */bin/sh") | |
80 (defconst mm-uu-shar-end-line "^exit 0\\|^$") | |
81 | |
82 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and | |
83 ;;; Peter von der Ah\'e <pahe@daimi.au.dk> | |
84 (defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") | |
85 (defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message") | |
86 | |
87 (defvar mm-uu-begin-line nil) | |
88 | |
89 (defconst mm-uu-identifier-alist | |
90 '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar) | |
91 (?- . forward))) | |
92 | |
93 (defvar mm-dissect-disposition "inline" | |
94 "The default disposition of uu parts. | |
95 This can be either \"inline\" or \"attachment\".") | |
96 | |
97 (defun mm-uu-configure-p (key val) | |
98 (member (cons key val) mm-uu-configure-list)) | |
99 | |
100 (defun mm-uu-configure (&optional symbol value) | |
101 (if symbol (set-default symbol value)) | |
102 (setq mm-uu-begin-line nil) | |
103 (mapcar '(lambda (type) | |
104 (if (mm-uu-configure-p type 'disabled) | |
105 nil | |
106 (setq mm-uu-begin-line | |
107 (concat mm-uu-begin-line | |
108 (if mm-uu-begin-line "\\|") | |
109 (symbol-value | |
110 (intern (concat "mm-uu-" (symbol-name type) | |
111 "-begin-line"))))))) | |
112 '(uu postscript binhex shar forward))) | |
113 | |
114 (defcustom mm-uu-configure-list nil | |
115 "A list of mm-uu configuration. | |
116 To disable dissecting shar codes, for instance, add | |
117 `(shar . disabled)' to this list." | |
118 :type '(repeat (cons | |
119 (choice (item postscript) | |
120 (item uu) | |
121 (item binhex) | |
122 (item shar) | |
123 (item forward)) | |
124 (choice (item disabled)))) | |
125 :group 'gnus-article-mime | |
126 :set 'mm-uu-configure) | |
127 | |
128 (mm-uu-configure) | |
129 | |
130 ;;;### autoload | |
131 | |
132 (defun mm-uu-dissect () | |
133 "Dissect the current buffer and return a list of uu handles." | |
134 (let (text-start start-char end-char | |
135 type file-name end-line result text-plain-type | |
136 start-char-1 end-char-1 | |
137 (case-fold-search t)) | |
138 (save-excursion | |
139 (save-restriction | |
140 (mail-narrow-to-head) | |
141 (goto-char (point-max))) | |
142 (forward-line) | |
143 ;;; gnus-decoded is a fake charset, which means no further | |
144 ;;; decoding. | |
145 (setq text-start (point) | |
146 text-plain-type '("text/plain" (charset . gnus-decoded))) | |
147 (while (re-search-forward mm-uu-begin-line nil t) | |
148 (setq start-char (match-beginning 0)) | |
149 (setq type (cdr (assq (aref (match-string 0) 0) | |
150 mm-uu-identifier-alist))) | |
151 (setq file-name | |
152 (if (and (eq type 'uu) | |
153 (looking-at "\\(.+\\)$")) | |
154 (and (match-string 1) | |
155 (let ((nnheader-file-name-translation-alist | |
156 '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) | |
157 (nnheader-translate-file-chars (match-string 1)))))) | |
158 (forward-line);; in case of failure | |
159 (setq start-char-1 (point)) | |
160 (setq end-line (symbol-value | |
161 (intern (concat "mm-uu-" (symbol-name type) | |
162 "-end-line")))) | |
163 (when (and (re-search-forward end-line nil t) | |
164 (not (eq (match-beginning 0) (match-end 0)))) | |
165 (setq end-char-1 (match-beginning 0)) | |
166 (forward-line) | |
167 (setq end-char (point)) | |
168 (when (cond | |
169 ((eq type 'binhex) | |
170 (setq file-name | |
171 (ignore-errors | |
172 (binhex-decode-region start-char end-char t)))) | |
173 ((eq type 'forward) | |
174 (save-excursion | |
175 (goto-char start-char-1) | |
176 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) | |
177 (t t)) | |
178 (if (> start-char text-start) | |
179 (push | |
180 (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) | |
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 | |
220 (if (> (point-max) (1+ text-start)) | |
221 (push | |
222 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) | |
223 text-plain-type) | |
224 result)) | |
225 (setq result (cons "multipart/mixed" (nreverse result)))) | |
226 result))) | |
227 | |
228 ;;;### autoload | |
229 (defun mm-uu-test () | |
230 "Check whether the current buffer contains uu stuffs." | |
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) | |
249 | |
250 ;;; mm-uu.el ends here |