Mercurial > emacs
annotate lisp/gnus/mm-uu.el @ 34395:2f4a4d355834
(time-stamp-old-format-warn): reorder custom
choices to match documentation string.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Sat, 09 Dec 2000 13:22:51 +0000 |
parents | 2c4faf64d4ca |
children | f04f551e94ce |
rev | line source |
---|---|
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
1 ;;; mm-uu.el -- Return uu stuff as mm handles |
31717 | 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) | |
33820 | 34 (require 'uudecode) |
31717 | 35 |
36 (eval-and-compile | |
37 (autoload 'binhex-decode-region "binhex") | |
33820 | 38 (autoload 'binhex-decode-region-external "binhex")) |
31717 | 39 |
40 (defun mm-uu-copy-to-buffer (from to) | |
33820 | 41 "Copy the contents of the current buffer to a fresh buffer. |
42 Return that buffer." | |
31717 | 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 | |
33820 | 57 ;; This is not the right place for this. uudecode.el should decide |
58 ;; whether or not to use a program with a single interface, but I | |
59 ;; guess it's too late now. Also the default should depend on a test | |
60 ;; for the program. -- fx | |
31717 | 61 (defcustom mm-uu-decode-function 'uudecode-decode-region |
62 "*Function to uudecode. | |
33820 | 63 Internal function is done in Lisp by default, therefore decoding may |
64 appear to be horribly slow. You can make Gnus use an external | |
31717 | 65 decoder, such as uudecode." |
33820 | 66 :type '(choice |
67 (function-item :tag "Internal" uudecode-decode-region) | |
68 (function-item :tag "External" uudecode-decode-region-external)) | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
69 :group 'gnus-article-mime) |
31717 | 70 |
71 (defconst mm-uu-binhex-begin-line | |
72 "^:...............................................................$") | |
73 (defconst mm-uu-binhex-end-line ":$") | |
74 | |
75 (defcustom mm-uu-binhex-decode-function 'binhex-decode-region | |
76 "*Function to binhex decode. | |
33820 | 77 Internal function is done in Lisp by default, therefore decoding may |
78 appear to be horribly slow. You can make Gnus use an external | |
31717 | 79 decoder, such as hexbin." |
33820 | 80 :type '(choice |
81 (function-item :tag "Internal" binhex-decode-region) | |
82 (function-item :tag "External" binhex-decode-region-external)) | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
83 :group 'gnus-article-mime) |
31717 | 84 |
85 (defconst mm-uu-shar-begin-line "^#! */bin/sh") | |
86 (defconst mm-uu-shar-end-line "^exit 0\\|^$") | |
87 | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
88 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and |
31717 | 89 ;;; Peter von der Ah\'e <pahe@daimi.au.dk> |
90 (defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") | |
91 (defconst mm-uu-forward-end-line "^-+ End \\(of \\)?forwarded message") | |
92 | |
93 (defvar mm-uu-begin-line nil) | |
94 | |
95 (defconst mm-uu-identifier-alist | |
96 '((?% . postscript) (?b . uu) (?: . binhex) (?# . shar) | |
97 (?- . forward))) | |
98 | |
99 (defvar mm-dissect-disposition "inline" | |
100 "The default disposition of uu parts. | |
101 This can be either \"inline\" or \"attachment\".") | |
102 | |
103 (defun mm-uu-configure-p (key val) | |
104 (member (cons key val) mm-uu-configure-list)) | |
105 | |
106 (defun mm-uu-configure (&optional symbol value) | |
107 (if symbol (set-default symbol value)) | |
108 (setq mm-uu-begin-line nil) | |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
109 (mapcar (lambda (type) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
110 (if (mm-uu-configure-p type 'disabled) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
111 nil |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
112 (setq mm-uu-begin-line |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
113 (concat mm-uu-begin-line |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
114 (if mm-uu-begin-line "\\|") |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
115 (symbol-value |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
116 (intern (concat "mm-uu-" (symbol-name type) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
117 "-begin-line"))))))) |
31717 | 118 '(uu postscript binhex shar forward))) |
119 | |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
120 ;; Needs to come after mm-uu-configure. |
33141
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
121 (defcustom mm-uu-configure-list nil |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
122 "Alist of mm-uu configurations to disable. |
33141
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
123 To disable dissecting shar codes, for instance, add |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
124 `(shar . disabled)' to this list." |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
125 :type '(repeat (choice (const :tag "postscript" (postscript . disabled)) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
126 (const :tag "uu" (uu . disabled)) |
33888
2c4faf64d4ca
(mm-uu-configure-list): Fix typo in :type.
Dave Love <fx@gnu.org>
parents:
33820
diff
changeset
|
127 (const :tag "binhex" (binhex . disabled)) |
33141
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
128 (const :tag "shar" (shar . disabled)) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
129 (const :tag "forward" (forward . disabled)))) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
130 :group 'gnus-article-mime |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
131 :set 'mm-uu-configure) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
132 |
31717 | 133 (mm-uu-configure) |
134 | |
135 ;;;### autoload | |
136 | |
137 (defun mm-uu-dissect () | |
138 "Dissect the current buffer and return a list of uu handles." | |
139 (let (text-start start-char end-char | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
140 type file-name end-line result text-plain-type |
31717 | 141 start-char-1 end-char-1 |
142 (case-fold-search t)) | |
143 (save-excursion | |
144 (save-restriction | |
145 (mail-narrow-to-head) | |
146 (goto-char (point-max))) | |
147 (forward-line) | |
148 ;;; gnus-decoded is a fake charset, which means no further | |
149 ;;; decoding. | |
150 (setq text-start (point) | |
151 text-plain-type '("text/plain" (charset . gnus-decoded))) | |
152 (while (re-search-forward mm-uu-begin-line nil t) | |
153 (setq start-char (match-beginning 0)) | |
154 (setq type (cdr (assq (aref (match-string 0) 0) | |
155 mm-uu-identifier-alist))) | |
156 (setq file-name | |
157 (if (and (eq type 'uu) | |
158 (looking-at "\\(.+\\)$")) | |
159 (and (match-string 1) | |
160 (let ((nnheader-file-name-translation-alist | |
161 '((?/ . ?,) (? . ?_) (?* . ?_) (?$ . ?_)))) | |
162 (nnheader-translate-file-chars (match-string 1)))))) | |
163 (forward-line);; in case of failure | |
164 (setq start-char-1 (point)) | |
165 (setq end-line (symbol-value | |
166 (intern (concat "mm-uu-" (symbol-name type) | |
167 "-end-line")))) | |
168 (when (and (re-search-forward end-line nil t) | |
169 (not (eq (match-beginning 0) (match-end 0)))) | |
170 (setq end-char-1 (match-beginning 0)) | |
171 (forward-line) | |
172 (setq end-char (point)) | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
173 (when (cond |
31717 | 174 ((eq type 'binhex) |
175 (setq file-name | |
176 (ignore-errors | |
177 (binhex-decode-region start-char end-char t)))) | |
178 ((eq type 'forward) | |
179 (save-excursion | |
180 (goto-char start-char-1) | |
181 (looking-at "[\r\n]*[a-zA-Z][a-zA-Z0-9-]*:"))) | |
182 (t t)) | |
183 (if (> start-char text-start) | |
184 (push | |
185 (mm-make-handle (mm-uu-copy-to-buffer text-start start-char) | |
186 text-plain-type) | |
187 result)) | |
188 (push | |
189 (cond | |
190 ((eq type 'postscript) | |
191 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) | |
192 '("application/postscript"))) | |
193 ((eq type 'forward) | |
194 (mm-make-handle (mm-uu-copy-to-buffer start-char-1 end-char-1) | |
195 '("message/rfc822" (charset . gnus-decoded)))) | |
196 ((eq type 'uu) | |
197 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) | |
198 (list (or (and file-name | |
199 (string-match "\\.[^\\.]+$" | |
200 file-name) | |
201 (mailcap-extension-to-mime | |
202 (match-string 0 file-name))) | |
203 "application/octet-stream")) | |
204 'x-uuencode nil | |
205 (if (and file-name (not (equal file-name ""))) | |
206 (list mm-dissect-disposition | |
207 (cons 'filename file-name))))) | |
208 ((eq type 'binhex) | |
209 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) | |
210 (list (or (and file-name | |
211 (string-match "\\.[^\\.]+$" file-name) | |
212 (mailcap-extension-to-mime | |
213 (match-string 0 file-name))) | |
214 "application/octet-stream")) | |
215 'x-binhex nil | |
216 (if (and file-name (not (equal file-name ""))) | |
217 (list mm-dissect-disposition | |
218 (cons 'filename file-name))))) | |
219 ((eq type 'shar) | |
220 (mm-make-handle (mm-uu-copy-to-buffer start-char end-char) | |
221 '("application/x-shar")))) | |
222 result) | |
223 (setq text-start end-char)))) | |
224 (when result | |
225 (if (> (point-max) (1+ text-start)) | |
226 (push | |
227 (mm-make-handle (mm-uu-copy-to-buffer text-start (point-max)) | |
228 text-plain-type) | |
229 result)) | |
230 (setq result (cons "multipart/mixed" (nreverse result)))) | |
231 result))) | |
232 | |
233 ;;;### autoload | |
234 (defun mm-uu-test () | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
235 "Check whether the current buffer contains uu stuff." |
31717 | 236 (save-excursion |
237 (goto-char (point-min)) | |
238 (let (type end-line result | |
239 (case-fold-search t)) | |
240 (while (and mm-uu-begin-line | |
241 (not result) (re-search-forward mm-uu-begin-line nil t)) | |
242 (forward-line) | |
243 (setq type (cdr (assq (aref (match-string 0) 0) | |
244 mm-uu-identifier-alist))) | |
245 (setq end-line (symbol-value | |
246 (intern (concat "mm-uu-" (symbol-name type) | |
247 "-end-line")))) | |
248 (if (and (re-search-forward end-line nil t) | |
249 (not (eq (match-beginning 0) (match-end 0)))) | |
250 (setq result t))) | |
251 result))) | |
252 | |
253 (provide 'mm-uu) | |
254 | |
255 ;;; mm-uu.el ends here |