Mercurial > emacs
annotate lisp/gnus/mm-uu.el @ 46677:86e8d59e2e49
*** empty log message ***
author | Dave Love <fx@gnu.org> |
---|---|
date | Wed, 24 Jul 2002 23:01:32 +0000 |
parents | eafbae0b1100 |
children | ee6f8dc4fe37 |
rev | line source |
---|---|
38413
a26d9b55abb6
Some fixes to follow coding conventions in files from Gnus.
Pavel Janík <Pavel@Janik.cz>
parents:
34752
diff
changeset
|
1 ;;; mm-uu.el --- return uu stuff as mm handles |
38727
eafbae0b1100
(mm-uu-dissect, mm-uu-test): Fix autoload cookies.
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
2 ;; Copyright (c) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. |
31717 | 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 ;;; Code: | |
27 | |
28 (eval-when-compile (require 'cl)) | |
29 (require 'mail-parse) | |
30 (require 'nnheader) | |
31 (require 'mm-decode) | |
32 (require 'mailcap) | |
33820 | 33 (require 'uudecode) |
34752
f04f551e94ce
* message.el (message-narrow-to-head-1): New function.
ShengHuo ZHU <zsh@cs.rochester.edu>
parents:
33888
diff
changeset
|
34 (require 'binhex) |
31717 | 35 |
36 (defun mm-uu-copy-to-buffer (from to) | |
33820 | 37 "Copy the contents of the current buffer to a fresh buffer. |
38 Return that buffer." | |
31717 | 39 (save-excursion |
40 (let ((obuf (current-buffer))) | |
41 (set-buffer (generate-new-buffer " *mm-uu*")) | |
42 (insert-buffer-substring obuf from to) | |
43 (current-buffer)))) | |
44 | |
45 ;;; postscript | |
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 | |
33820 | 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 | |
31717 | 57 (defcustom mm-uu-decode-function 'uudecode-decode-region |
58 "*Function to uudecode. | |
33820 | 59 Internal function is done in Lisp by default, therefore decoding may |
60 appear to be horribly slow. You can make Gnus use an external | |
31717 | 61 decoder, such as uudecode." |
33820 | 62 :type '(choice |
63 (function-item :tag "Internal" uudecode-decode-region) | |
64 (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
|
65 :group 'gnus-article-mime) |
31717 | 66 |
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 | |
72 "*Function to binhex decode. | |
33820 | 73 Internal function is done in Lisp by default, therefore decoding may |
74 appear to be horribly slow. You can make Gnus use an external | |
31717 | 75 decoder, such as hexbin." |
33820 | 76 :type '(choice |
77 (function-item :tag "Internal" binhex-decode-region) | |
78 (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
|
79 :group 'gnus-article-mime) |
31717 | 80 |
81 (defconst mm-uu-shar-begin-line "^#! */bin/sh") | |
82 (defconst mm-uu-shar-end-line "^exit 0\\|^$") | |
83 | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
84 ;;; Thanks to Edward J. Sabol <sabol@alderaan.gsfc.nasa.gov> and |
31717 | 85 ;;; Peter von der Ah\'e <pahe@daimi.au.dk> |
86 (defconst mm-uu-forward-begin-line "^-+ \\(Start of \\)?Forwarded message") | |
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 | |
95 (defvar mm-dissect-disposition "inline" | |
96 "The default disposition of uu parts. | |
97 This can be either \"inline\" or \"attachment\".") | |
98 | |
99 (defun mm-uu-configure-p (key val) | |
100 (member (cons key val) mm-uu-configure-list)) | |
101 | |
102 (defun mm-uu-configure (&optional symbol value) | |
103 (if symbol (set-default symbol value)) | |
104 (setq mm-uu-begin-line nil) | |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
105 (mapcar (lambda (type) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
106 (if (mm-uu-configure-p type 'disabled) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
107 nil |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
108 (setq mm-uu-begin-line |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
109 (concat mm-uu-begin-line |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
110 (if mm-uu-begin-line "\\|") |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
111 (symbol-value |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
112 (intern (concat "mm-uu-" (symbol-name type) |
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
113 "-begin-line"))))))) |
31717 | 114 '(uu postscript binhex shar forward))) |
115 | |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
116 ;; 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
|
117 (defcustom mm-uu-configure-list nil |
33265
191c9629d653
(mm-uu-configure): Unquote lambda.
Dave Love <fx@gnu.org>
parents:
33141
diff
changeset
|
118 "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
|
119 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
|
120 `(shar . disabled)' to this list." |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
121 :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
|
122 (const :tag "uu" (uu . disabled)) |
33888
2c4faf64d4ca
(mm-uu-configure-list): Fix typo in :type.
Dave Love <fx@gnu.org>
parents:
33820
diff
changeset
|
123 (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
|
124 (const :tag "shar" (shar . disabled)) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
125 (const :tag "forward" (forward . disabled)))) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
126 :group 'gnus-article-mime |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
127 :set 'mm-uu-configure) |
66b0773e0877
(mm-uu-configure-list): Move back to old location,
Miles Bader <miles@gnu.org>
parents:
33120
diff
changeset
|
128 |
31717 | 129 (mm-uu-configure) |
130 | |
38727
eafbae0b1100
(mm-uu-dissect, mm-uu-test): Fix autoload cookies.
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
131 ;;;###autoload |
31717 | 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 | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
135 type file-name end-line result text-plain-type |
31717 | 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)) | |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
168 (when (cond |
31717 | 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 | |
38727
eafbae0b1100
(mm-uu-dissect, mm-uu-test): Fix autoload cookies.
Gerd Moellmann <gerd@gnu.org>
parents:
38413
diff
changeset
|
228 ;;;###autoload |
31717 | 229 (defun mm-uu-test () |
33120
5d37eed2a6e2
(mm-uu-decode-function, mm-uu-binhex-decode-function):
Dave Love <fx@gnu.org>
parents:
31717
diff
changeset
|
230 "Check whether the current buffer contains uu stuff." |
31717 | 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 |