|
20
|
1 ;;; MIME support functions
|
|
|
2 ;;; Copyright (C) 1997 Kyle E. Jones
|
|
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-mime)
|
|
|
19
|
|
|
20 (defun vm-mime-error (&rest args)
|
|
|
21 (signal 'vm-mime-error (list (apply 'format args)))
|
|
|
22 (error "can't return from vm-mime-error"))
|
|
|
23
|
|
|
24 (if (fboundp 'define-error)
|
|
|
25 (define-error 'vm-mime-error "MIME error")
|
|
|
26 (put 'vm-mime-error 'error-conditions '(vm-mime-error error))
|
|
|
27 (put 'vm-mime-error 'error-message "MIME error"))
|
|
|
28
|
|
|
29 (defun vm-mm-layout-type (e) (aref e 0))
|
|
24
|
30 (defun vm-mm-layout-qtype (e) (aref e 1))
|
|
|
31 (defun vm-mm-layout-encoding (e) (aref e 2))
|
|
|
32 (defun vm-mm-layout-id (e) (aref e 3))
|
|
|
33 (defun vm-mm-layout-description (e) (aref e 4))
|
|
|
34 (defun vm-mm-layout-disposition (e) (aref e 5))
|
|
|
35 (defun vm-mm-layout-qdisposition (e) (aref e 6))
|
|
|
36 (defun vm-mm-layout-header-start (e) (aref e 7))
|
|
|
37 (defun vm-mm-layout-body-start (e) (aref e 8))
|
|
|
38 (defun vm-mm-layout-body-end (e) (aref e 9))
|
|
|
39 (defun vm-mm-layout-parts (e) (aref e 10))
|
|
146
|
40 (defun vm-mm-layout-cache (e) (aref e 11))
|
|
131
|
41 ;; if display of MIME part fails, error string will be here.
|
|
146
|
42 (defun vm-mm-layout-display-error (e) (aref e 12))
|
|
20
|
43
|
|
30
|
44 (defun vm-set-mm-layout-type (e type) (aset e 0 type))
|
|
24
|
45 (defun vm-set-mm-layout-cache (e c) (aset e 11 c))
|
|
146
|
46 (defun vm-set-mm-layout-display-error (e c) (aset e 12 c))
|
|
20
|
47
|
|
|
48 (defun vm-mm-layout (m)
|
|
|
49 (or (vm-mime-layout-of m)
|
|
|
50 (progn (vm-set-mime-layout-of
|
|
|
51 m
|
|
|
52 (condition-case data
|
|
|
53 (vm-mime-parse-entity m)
|
|
114
|
54 (vm-mime-error (message "%s" (car (cdr data))))))
|
|
20
|
55 (vm-mime-layout-of m))))
|
|
|
56
|
|
|
57 (defun vm-mm-encoded-header (m)
|
|
|
58 (or (vm-mime-encoded-header-flag-of m)
|
|
|
59 (progn (setq m (vm-real-message-of m))
|
|
|
60 (vm-set-mime-encoded-header-flag-of
|
|
|
61 m
|
|
|
62 (save-excursion
|
|
|
63 (set-buffer (vm-buffer-of m))
|
|
|
64 (save-excursion
|
|
|
65 (save-restriction
|
|
|
66 (widen)
|
|
|
67 (goto-char (vm-headers-of m))
|
|
|
68 (or (re-search-forward vm-mime-encoded-word-regexp
|
|
|
69 (vm-text-of m) t)
|
|
|
70 'none)))))
|
|
|
71 (vm-mime-encoded-header-flag-of m))))
|
|
|
72
|
|
|
73 (defun vm-mime-Q-decode-region (start end)
|
|
|
74 (let ((buffer-read-only nil))
|
|
|
75 (subst-char-in-region start end ?_ (string-to-char " ") t)
|
|
|
76 (vm-mime-qp-decode-region start end)))
|
|
|
77
|
|
|
78 (fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region)
|
|
|
79
|
|
|
80 (defun vm-mime-Q-encode-region (start end)
|
|
|
81 (let ((buffer-read-only nil))
|
|
|
82 (subst-char-in-region start end (string-to-char " ") ?_ t)
|
|
24
|
83 (vm-mime-qp-encode-region start end t)))
|
|
20
|
84
|
|
24
|
85 (defun vm-mime-B-encode-region (start end)
|
|
|
86 (vm-mime-base64-encode-region start end nil t))
|
|
20
|
87
|
|
|
88 (defun vm-mime-crlf-to-lf-region (start end)
|
|
|
89 (let ((buffer-read-only nil))
|
|
|
90 (save-excursion
|
|
|
91 (save-restriction
|
|
|
92 (narrow-to-region start end)
|
|
|
93 (goto-char start)
|
|
|
94 (while (search-forward "\r\n" nil t)
|
|
|
95 (delete-char -2)
|
|
|
96 (insert "\n"))))))
|
|
|
97
|
|
|
98 (defun vm-mime-lf-to-crlf-region (start end)
|
|
|
99 (let ((buffer-read-only nil))
|
|
|
100 (save-excursion
|
|
|
101 (save-restriction
|
|
|
102 (narrow-to-region start end)
|
|
|
103 (goto-char start)
|
|
|
104 (while (search-forward "\n" nil t)
|
|
|
105 (delete-char -1)
|
|
|
106 (insert "\r\n"))))))
|
|
|
107
|
|
|
108 (defun vm-mime-charset-decode-region (charset start end)
|
|
24
|
109 (or (markerp end) (setq end (vm-marker end)))
|
|
120
|
110 (cond (vm-xemacs-mule-p
|
|
24
|
111 (if (eq (device-type) 'x)
|
|
|
112 (let ((buffer-read-only nil)
|
|
|
113 (cell (cdr (vm-string-assoc
|
|
|
114 charset
|
|
|
115 vm-mime-mule-charset-to-coding-alist)))
|
|
|
116 (oend (marker-position end))
|
|
|
117 (opoint (point)))
|
|
|
118 (if cell
|
|
|
119 (progn
|
|
|
120 (set-marker end (+ start
|
|
|
121 (or (decode-coding-region
|
|
|
122 start end (car cell))
|
|
|
123 (- oend start))))
|
|
|
124 (put-text-property start end 'vm-string t)
|
|
|
125 (put-text-property start end 'vm-charset charset)
|
|
|
126 (put-text-property start end 'vm-coding (car cell))))
|
|
|
127 ;; In XEmacs 20.0 beta93 decode-coding-region moves point.
|
|
|
128 (goto-char opoint))))
|
|
|
129 ((not (vm-multiple-fonts-possible-p)) nil)
|
|
|
130 ((vm-string-member charset vm-mime-default-face-charsets) nil)
|
|
|
131 (t
|
|
|
132 (let ((font (cdr (vm-string-assoc
|
|
|
133 charset
|
|
|
134 vm-mime-charset-font-alist)))
|
|
|
135 (face (make-face (make-symbol "temp-face")))
|
|
|
136 (e (vm-make-extent start end)))
|
|
|
137 (put-text-property start end 'vm-string t)
|
|
|
138 (put-text-property start end 'vm-charset charset)
|
|
|
139 (if font
|
|
|
140 (condition-case data
|
|
|
141 (progn (set-face-font face font)
|
|
|
142 (vm-set-extent-property e 'face face))
|
|
|
143 (error nil)))))))
|
|
20
|
144
|
|
|
145 (defun vm-mime-transfer-decode-region (layout start end)
|
|
|
146 (let ((case-fold-search t) (crlf nil))
|
|
|
147 (cond ((string-match "^base64$" (vm-mm-layout-encoding layout))
|
|
|
148 (cond ((vm-mime-types-match "text"
|
|
|
149 (car (vm-mm-layout-type layout)))
|
|
|
150 (setq crlf t))
|
|
|
151 ((vm-mime-types-match "message"
|
|
|
152 (car (vm-mm-layout-type layout)))
|
|
|
153 (setq crlf t)))
|
|
|
154 (vm-mime-base64-decode-region start end crlf))
|
|
|
155 ((string-match "^quoted-printable$"
|
|
|
156 (vm-mm-layout-encoding layout))
|
|
|
157 (vm-mime-qp-decode-region start end)))))
|
|
|
158
|
|
|
159 (defun vm-mime-base64-decode-region (start end &optional crlf)
|
|
26
|
160 (message "Decoding base64...")
|
|
20
|
161 (let ((work-buffer nil)
|
|
|
162 (done nil)
|
|
|
163 (counter 0)
|
|
|
164 (bits 0)
|
|
|
165 (lim 0) inputpos
|
|
|
166 (non-data-chars (concat "^=" vm-mime-base64-alphabet)))
|
|
|
167 (unwind-protect
|
|
|
168 (save-excursion
|
|
|
169 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
170 (buffer-disable-undo work-buffer)
|
|
|
171 (if vm-mime-base64-decoder-program
|
|
|
172 (let* ((binary-process-output t) ; any text already has CRLFs
|
|
|
173 (status (apply 'vm-run-command-on-region
|
|
|
174 start end work-buffer
|
|
|
175 vm-mime-base64-decoder-program
|
|
|
176 vm-mime-base64-decoder-switches)))
|
|
|
177 (if (not (eq status t))
|
|
|
178 (vm-mime-error "%s" (cdr status))))
|
|
|
179 (goto-char start)
|
|
|
180 (skip-chars-forward non-data-chars end)
|
|
|
181 (while (not done)
|
|
|
182 (setq inputpos (point))
|
|
|
183 (cond
|
|
|
184 ((> (skip-chars-forward vm-mime-base64-alphabet end) 0)
|
|
|
185 (setq lim (point))
|
|
|
186 (while (< inputpos lim)
|
|
|
187 (setq bits (+ bits
|
|
|
188 (aref vm-mime-base64-alphabet-decoding-vector
|
|
|
189 (char-after inputpos))))
|
|
|
190 (vm-increment counter)
|
|
|
191 (vm-increment inputpos)
|
|
|
192 (cond ((= counter 4)
|
|
|
193 (vm-insert-char (lsh bits -16) 1 nil work-buffer)
|
|
|
194 (vm-insert-char (logand (lsh bits -8) 255) 1 nil
|
|
|
195 work-buffer)
|
|
|
196 (vm-insert-char (logand bits 255) 1 nil work-buffer)
|
|
|
197 (setq bits 0 counter 0))
|
|
|
198 (t (setq bits (lsh bits 6)))))))
|
|
|
199 (cond
|
|
|
200 ((= (point) end)
|
|
|
201 (if (not (zerop counter))
|
|
|
202 (vm-mime-error "at least %d bits missing at end of base64 encoding"
|
|
|
203 (* (- 4 counter) 6)))
|
|
|
204 (setq done t))
|
|
|
205 ((= (char-after (point)) 61) ; 61 is ASCII equals
|
|
|
206 (setq done t)
|
|
|
207 (cond ((= counter 1)
|
|
|
208 (vm-mime-error "at least 2 bits missing at end of base64 encoding"))
|
|
|
209 ((= counter 2)
|
|
|
210 (vm-insert-char (lsh bits -10) 1 nil work-buffer))
|
|
|
211 ((= counter 3)
|
|
|
212 (vm-insert-char (lsh bits -16) 1 nil work-buffer)
|
|
|
213 (vm-insert-char (logand (lsh bits -8) 255)
|
|
|
214 1 nil work-buffer))
|
|
|
215 ((= counter 0) t)))
|
|
|
216 (t (skip-chars-forward non-data-chars end)))))
|
|
|
217 (and crlf
|
|
|
218 (save-excursion
|
|
|
219 (set-buffer work-buffer)
|
|
|
220 (vm-mime-crlf-to-lf-region (point-min) (point-max))))
|
|
|
221 (or (markerp end) (setq end (vm-marker end)))
|
|
|
222 (goto-char start)
|
|
|
223 (insert-buffer-substring work-buffer)
|
|
|
224 (delete-region (point) end))
|
|
|
225 (and work-buffer (kill-buffer work-buffer))))
|
|
26
|
226 (message "Decoding base64... done"))
|
|
20
|
227
|
|
24
|
228 (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding)
|
|
|
229 (and (> (- end start) 200)
|
|
26
|
230 (message "Encoding base64..."))
|
|
20
|
231 (let ((work-buffer nil)
|
|
|
232 (counter 0)
|
|
|
233 (cols 0)
|
|
|
234 (bits 0)
|
|
|
235 (alphabet vm-mime-base64-alphabet)
|
|
|
236 inputpos)
|
|
|
237 (unwind-protect
|
|
|
238 (save-excursion
|
|
|
239 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
240 (buffer-disable-undo work-buffer)
|
|
|
241 (if crlf
|
|
|
242 (progn
|
|
|
243 (or (markerp end) (setq end (vm-marker end)))
|
|
|
244 (vm-mime-lf-to-crlf-region start end)))
|
|
|
245 (if vm-mime-base64-encoder-program
|
|
|
246 (let ((status (apply 'vm-run-command-on-region
|
|
|
247 start end work-buffer
|
|
|
248 vm-mime-base64-encoder-program
|
|
|
249 vm-mime-base64-encoder-switches)))
|
|
|
250 (if (not (eq status t))
|
|
26
|
251 (vm-mime-error "%s" (cdr status)))
|
|
|
252 (if B-encoding
|
|
|
253 (progn
|
|
|
254 ;; if we're B encoding, strip out the line breaks
|
|
|
255 (goto-char (point-min))
|
|
|
256 (while (search-forward "\n" nil t)
|
|
|
257 (delete-char -1)))))
|
|
20
|
258 (setq inputpos start)
|
|
|
259 (while (< inputpos end)
|
|
|
260 (setq bits (+ bits (char-after inputpos)))
|
|
|
261 (vm-increment counter)
|
|
|
262 (cond ((= counter 3)
|
|
|
263 (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil
|
|
|
264 work-buffer)
|
|
|
265 (vm-insert-char (aref alphabet (logand (lsh bits -12) 63))
|
|
|
266 1 nil work-buffer)
|
|
|
267 (vm-insert-char (aref alphabet (logand (lsh bits -6) 63))
|
|
|
268 1 nil work-buffer)
|
|
|
269 (vm-insert-char (aref alphabet (logand bits 63)) 1 nil
|
|
|
270 work-buffer)
|
|
|
271 (setq cols (+ cols 4))
|
|
|
272 (cond ((= cols 72)
|
|
24
|
273 (setq cols 0)
|
|
|
274 (if (not B-encoding)
|
|
|
275 (vm-insert-char ?\n 1 nil work-buffer))))
|
|
20
|
276 (setq bits 0 counter 0))
|
|
|
277 (t (setq bits (lsh bits 8))))
|
|
|
278 (vm-increment inputpos))
|
|
|
279 ;; write out any remaining bits with appropriate padding
|
|
|
280 (if (= counter 0)
|
|
|
281 nil
|
|
|
282 (setq bits (lsh bits (- 16 (* 8 counter))))
|
|
|
283 (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil
|
|
|
284 work-buffer)
|
|
|
285 (vm-insert-char (aref alphabet (logand (lsh bits -12) 63))
|
|
|
286 1 nil work-buffer)
|
|
|
287 (if (= counter 1)
|
|
|
288 (vm-insert-char ?= 2 nil work-buffer)
|
|
|
289 (vm-insert-char (aref alphabet (logand (lsh bits -6) 63))
|
|
|
290 1 nil work-buffer)
|
|
|
291 (vm-insert-char ?= 1 nil work-buffer)))
|
|
|
292 (if (> cols 0)
|
|
|
293 (vm-insert-char ?\n 1 nil work-buffer)))
|
|
|
294 (or (markerp end) (setq end (vm-marker end)))
|
|
|
295 (goto-char start)
|
|
|
296 (insert-buffer-substring work-buffer)
|
|
24
|
297 (delete-region (point) end)
|
|
|
298 (and (> (- end start) 200)
|
|
26
|
299 (message "Encoding base64... done"))
|
|
24
|
300 (- end start))
|
|
|
301 (and work-buffer (kill-buffer work-buffer)))))
|
|
20
|
302
|
|
|
303 (defun vm-mime-qp-decode-region (start end)
|
|
24
|
304 (and (> (- end start) 200)
|
|
26
|
305 (message "Decoding quoted-printable..."))
|
|
20
|
306 (let ((work-buffer nil)
|
|
|
307 (buf (current-buffer))
|
|
|
308 (case-fold-search nil)
|
|
|
309 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
|
|
|
310 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
|
|
|
311 (?8 . 8) (?9 . 9) (?A . 10) (?B . 11)
|
|
|
312 (?C . 12) (?D . 13) (?E . 14) (?F . 15)))
|
|
|
313 inputpos stop-point copy-point)
|
|
|
314 (unwind-protect
|
|
|
315 (save-excursion
|
|
|
316 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
317 (buffer-disable-undo work-buffer)
|
|
|
318 (goto-char start)
|
|
|
319 (setq inputpos start)
|
|
|
320 (while (< inputpos end)
|
|
|
321 (skip-chars-forward "^=\n" end)
|
|
|
322 (setq stop-point (point))
|
|
|
323 (cond ((looking-at "\n")
|
|
|
324 ;; spaces or tabs before a hard line break must be ignored
|
|
|
325 (skip-chars-backward " \t")
|
|
|
326 (setq copy-point (point))
|
|
|
327 (goto-char stop-point))
|
|
|
328 (t (setq copy-point stop-point)))
|
|
|
329 (save-excursion
|
|
|
330 (set-buffer work-buffer)
|
|
|
331 (insert-buffer-substring buf inputpos copy-point))
|
|
|
332 (cond ((= (point) end) t)
|
|
|
333 ((looking-at "\n")
|
|
|
334 (vm-insert-char ?\n 1 nil work-buffer)
|
|
|
335 (forward-char))
|
|
|
336 (t ;; looking at =
|
|
|
337 (forward-char)
|
|
|
338 (cond ((looking-at "[0-9A-F][0-9A-F]")
|
|
|
339 (vm-insert-char (+ (* (cdr (assq (char-after (point))
|
|
|
340 hex-digit-alist))
|
|
|
341 16)
|
|
|
342 (cdr (assq (char-after
|
|
|
343 (1+ (point)))
|
|
|
344 hex-digit-alist)))
|
|
|
345 1 nil work-buffer)
|
|
|
346 (forward-char 2))
|
|
|
347 ((looking-at "\n") ; soft line break
|
|
|
348 (forward-char))
|
|
|
349 ((looking-at "\r")
|
|
118
|
350 ;; assume the user's goatloving
|
|
20
|
351 ;; delivery software didn't convert
|
|
|
352 ;; from Internet's CRLF newline
|
|
|
353 ;; convention to the local LF
|
|
|
354 ;; convention.
|
|
|
355 (forward-char))
|
|
|
356 ((looking-at "[ \t]")
|
|
|
357 ;; garbage added in transit
|
|
|
358 (skip-chars-forward " \t" end))
|
|
|
359 (t (vm-mime-error "something other than line break or hex digits after = in quoted-printable encoding")))))
|
|
|
360 (setq inputpos (point)))
|
|
|
361 (or (markerp end) (setq end (vm-marker end)))
|
|
|
362 (goto-char start)
|
|
|
363 (insert-buffer-substring work-buffer)
|
|
|
364 (delete-region (point) end))
|
|
|
365 (and work-buffer (kill-buffer work-buffer))))
|
|
24
|
366 (and (> (- end start) 200)
|
|
26
|
367 (message "Decoding quoted-printable... done")))
|
|
20
|
368
|
|
30
|
369 (defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from)
|
|
24
|
370 (and (> (- end start) 200)
|
|
26
|
371 (message "Encoding quoted-printable..."))
|
|
20
|
372 (let ((work-buffer nil)
|
|
|
373 (buf (current-buffer))
|
|
|
374 (cols 0)
|
|
|
375 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
|
|
|
376 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
|
|
|
377 (?8 . 8) (?9 . 9) (?A . 10) (?B . 11)
|
|
|
378 (?C . 12) (?D . 13) (?E . 14) (?F . 15)))
|
|
|
379 char inputpos)
|
|
|
380 (unwind-protect
|
|
|
381 (save-excursion
|
|
|
382 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
383 (buffer-disable-undo work-buffer)
|
|
|
384 (setq inputpos start)
|
|
|
385 (while (< inputpos end)
|
|
|
386 (setq char (char-after inputpos))
|
|
|
387 (cond ((= char ?\n)
|
|
|
388 (vm-insert-char char 1 nil work-buffer)
|
|
|
389 (setq cols 0))
|
|
114
|
390 ((and (= char 32)
|
|
|
391 (not (= (1+ inputpos) end))
|
|
|
392 (not (= ?\n (char-after (1+ inputpos)))))
|
|
20
|
393 (vm-insert-char char 1 nil work-buffer)
|
|
|
394 (vm-increment cols))
|
|
30
|
395 ((or (< char 33) (> char 126) (= char 61)
|
|
|
396 (and quote-from (= cols 0) (let ((case-fold-search nil))
|
|
155
|
397 (looking-at "From ")))
|
|
|
398 (and (= cols 0) (= char ?.)
|
|
|
399 (looking-at "\\.\\(\n\\|\\'\\)")))
|
|
20
|
400 (vm-insert-char ?= 1 nil work-buffer)
|
|
|
401 (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist))
|
|
|
402 1 nil work-buffer)
|
|
|
403 (vm-insert-char (car (rassq (logand char 15)
|
|
|
404 hex-digit-alist))
|
|
|
405 1 nil work-buffer)
|
|
|
406 (setq cols (+ cols 3)))
|
|
|
407 (t (vm-insert-char char 1 nil work-buffer)
|
|
|
408 (vm-increment cols)))
|
|
|
409 (cond ((> cols 70)
|
|
24
|
410 (setq cols 0)
|
|
|
411 (if Q-encoding
|
|
|
412 nil
|
|
|
413 (vm-insert-char ?= 1 nil work-buffer)
|
|
|
414 (vm-insert-char ?\n 1 nil work-buffer))))
|
|
20
|
415 (vm-increment inputpos))
|
|
|
416 (or (markerp end) (setq end (vm-marker end)))
|
|
|
417 (goto-char start)
|
|
|
418 (insert-buffer-substring work-buffer)
|
|
24
|
419 (delete-region (point) end)
|
|
|
420 (and (> (- end start) 200)
|
|
26
|
421 (message "Encoding quoted-printable... done"))
|
|
24
|
422 (- end start))
|
|
|
423 (and work-buffer (kill-buffer work-buffer)))))
|
|
20
|
424
|
|
|
425 (defun vm-decode-mime-message-headers (m)
|
|
|
426 (let ((case-fold-search t)
|
|
|
427 (buffer-read-only nil)
|
|
|
428 charset encoding match-start match-end start end)
|
|
|
429 (save-excursion
|
|
|
430 (goto-char (vm-headers-of m))
|
|
|
431 (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t)
|
|
|
432 (setq match-start (match-beginning 0)
|
|
|
433 match-end (match-end 0)
|
|
30
|
434 charset (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
435 encoding (buffer-substring (match-beginning 2) (match-end 2))
|
|
20
|
436 start (match-beginning 3)
|
|
|
437 end (vm-marker (match-end 3)))
|
|
|
438 ;; don't change anything if we can't display the
|
|
|
439 ;; character set properly.
|
|
|
440 (if (not (vm-mime-charset-internally-displayable-p charset))
|
|
|
441 nil
|
|
|
442 (delete-region end match-end)
|
|
30
|
443 (condition-case data
|
|
|
444 (cond ((string-match "B" encoding)
|
|
|
445 (vm-mime-B-decode-region start end))
|
|
|
446 ((string-match "Q" encoding)
|
|
|
447 (vm-mime-Q-decode-region start end))
|
|
|
448 (t (vm-mime-error "unknown encoded word encoding, %s"
|
|
|
449 encoding)))
|
|
|
450 (vm-mime-error (apply 'message (cdr data))
|
|
|
451 (goto-char start)
|
|
|
452 (insert "**invalid encoded word**")
|
|
|
453 (delete-region (point) end)))
|
|
20
|
454 (vm-mime-charset-decode-region charset start end)
|
|
114
|
455 (delete-region match-start start))))))
|
|
20
|
456
|
|
|
457 (defun vm-decode-mime-encoded-words ()
|
|
|
458 (let ((case-fold-search t)
|
|
|
459 (buffer-read-only nil)
|
|
|
460 charset encoding match-start match-end start end)
|
|
|
461 (save-excursion
|
|
|
462 (goto-char (point-min))
|
|
|
463 (while (re-search-forward vm-mime-encoded-word-regexp nil t)
|
|
|
464 (setq match-start (match-beginning 0)
|
|
|
465 match-end (match-end 0)
|
|
30
|
466 charset (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
467 encoding (buffer-substring (match-beginning 2) (match-end 2))
|
|
20
|
468 start (match-beginning 3)
|
|
|
469 end (vm-marker (match-end 3)))
|
|
|
470 ;; don't change anything if we can't display the
|
|
|
471 ;; character set properly.
|
|
|
472 (if (not (vm-mime-charset-internally-displayable-p charset))
|
|
|
473 nil
|
|
|
474 (delete-region end match-end)
|
|
30
|
475 (condition-case data
|
|
|
476 (cond ((string-match "B" encoding)
|
|
|
477 (vm-mime-B-decode-region start end))
|
|
|
478 ((string-match "Q" encoding)
|
|
|
479 (vm-mime-Q-decode-region start end))
|
|
|
480 (t (vm-mime-error "unknown encoded word encoding, %s"
|
|
|
481 encoding)))
|
|
|
482 (vm-mime-error (apply 'message (cdr data))
|
|
|
483 (goto-char start)
|
|
|
484 (insert "**invalid encoded word**")
|
|
|
485 (delete-region (point) end)))
|
|
20
|
486 (vm-mime-charset-decode-region charset start end)
|
|
|
487 (delete-region match-start start))))))
|
|
|
488
|
|
24
|
489 (defun vm-decode-mime-encoded-words-in-string (string)
|
|
20
|
490 (if (and vm-display-using-mime
|
|
|
491 (string-match vm-mime-encoded-word-regexp string))
|
|
|
492 (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words)
|
|
|
493 string ))
|
|
|
494
|
|
24
|
495 (defun vm-reencode-mime-encoded-words ()
|
|
|
496 (let ((charset nil)
|
|
|
497 start coding pos q-encoding
|
|
|
498 old-size
|
|
|
499 (case-fold-search t)
|
|
|
500 (done nil))
|
|
|
501 (save-excursion
|
|
|
502 (setq start (point-min))
|
|
|
503 (while (not done)
|
|
|
504 (setq charset (get-text-property start 'vm-charset))
|
|
|
505 (setq pos (next-single-property-change start 'vm-charset))
|
|
|
506 (or pos (setq pos (point-max) done t))
|
|
|
507 (if charset
|
|
|
508 (progn
|
|
|
509 (if (setq coding (get-text-property start 'vm-coding))
|
|
|
510 (progn
|
|
|
511 (setq old-size (buffer-size))
|
|
|
512 (encode-coding-region start pos coding)
|
|
|
513 (setq pos (+ pos (- (buffer-size) old-size)))))
|
|
|
514 (setq pos
|
|
|
515 (+ start
|
|
|
516 (if (setq q-encoding
|
|
|
517 (string-match "^iso-8859-\\|^us-ascii"
|
|
|
518 charset))
|
|
|
519 (vm-mime-Q-encode-region start pos)
|
|
|
520 (vm-mime-B-encode-region start pos))))
|
|
|
521 (goto-char pos)
|
|
|
522 (insert "?=")
|
|
|
523 (setq pos (point))
|
|
|
524 (goto-char start)
|
|
|
525 (insert "=?" charset "?" (if q-encoding "Q" "B") "?")))
|
|
|
526 (setq start pos)))))
|
|
|
527
|
|
|
528 (defun vm-reencode-mime-encoded-words-in-string (string)
|
|
|
529 (if (and vm-display-using-mime
|
|
|
530 (text-property-any 0 (length string) 'vm-string t string))
|
|
|
531 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words)
|
|
|
532 string ))
|
|
|
533
|
|
118
|
534 (fset 'vm-mime-parse-content-header 'vm-parse-structured-header)
|
|
20
|
535
|
|
|
536 (defun vm-mime-get-header-contents (header-name-regexp)
|
|
|
537 (let ((contents nil)
|
|
|
538 regexp)
|
|
|
539 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
|
|
|
540 (save-excursion
|
|
|
541 (let ((case-fold-search t))
|
|
|
542 (if (and (re-search-forward regexp nil t)
|
|
|
543 (match-beginning 1)
|
|
|
544 (progn (goto-char (match-beginning 0))
|
|
|
545 (vm-match-header)))
|
|
|
546 (vm-matched-header-contents)
|
|
|
547 nil )))))
|
|
|
548
|
|
|
549 (defun vm-mime-parse-entity (&optional m default-type default-encoding)
|
|
24
|
550 (let ((case-fold-search t) version type qtype encoding id description
|
|
|
551 disposition qdisposition boundary boundary-regexp start
|
|
20
|
552 multipart-list c-t c-t-e done p returnval)
|
|
|
553 (catch 'return-value
|
|
|
554 (save-excursion
|
|
|
555 (if m
|
|
|
556 (progn
|
|
|
557 (setq m (vm-real-message-of m))
|
|
|
558 (set-buffer (vm-buffer-of m))))
|
|
|
559 (save-excursion
|
|
|
560 (save-restriction
|
|
|
561 (if m
|
|
|
562 (progn
|
|
|
563 (setq version (vm-get-header-contents m "MIME-Version:")
|
|
|
564 version (car (vm-mime-parse-content-header version))
|
|
|
565 type (vm-get-header-contents m "Content-Type:")
|
|
24
|
566 qtype (vm-mime-parse-content-header type ?\; t)
|
|
20
|
567 type (vm-mime-parse-content-header type ?\;)
|
|
|
568 encoding (or (vm-get-header-contents
|
|
|
569 m "Content-Transfer-Encoding:")
|
|
|
570 "7bit")
|
|
175
|
571 encoding (or (car
|
|
|
572 (vm-mime-parse-content-header encoding))
|
|
|
573 "7bit")
|
|
20
|
574 id (vm-get-header-contents m "Content-ID:")
|
|
|
575 id (car (vm-mime-parse-content-header id))
|
|
|
576 description (vm-get-header-contents
|
|
|
577 m "Content-Description:")
|
|
|
578 description (and description
|
|
|
579 (if (string-match "^[ \t\n]$"
|
|
|
580 description)
|
|
|
581 nil
|
|
|
582 description))
|
|
|
583 disposition (vm-get-header-contents
|
|
|
584 m "Content-Disposition:")
|
|
24
|
585 qdisposition (and disposition
|
|
|
586 (vm-mime-parse-content-header
|
|
|
587 disposition ?\; t))
|
|
20
|
588 disposition (and disposition
|
|
|
589 (vm-mime-parse-content-header
|
|
|
590 disposition ?\;)))
|
|
|
591 (widen)
|
|
|
592 (narrow-to-region (vm-headers-of m) (vm-text-end-of m)))
|
|
|
593 (goto-char (point-min))
|
|
|
594 (setq type (vm-mime-get-header-contents "Content-Type:")
|
|
24
|
595 qtype (or (vm-mime-parse-content-header type ?\; t)
|
|
|
596 default-type)
|
|
20
|
597 type (or (vm-mime-parse-content-header type ?\;)
|
|
|
598 default-type)
|
|
|
599 encoding (or (vm-mime-get-header-contents
|
|
|
600 "Content-Transfer-Encoding:")
|
|
|
601 default-encoding)
|
|
175
|
602 encoding (or (car (vm-mime-parse-content-header encoding))
|
|
|
603 default-encoding)
|
|
20
|
604 id (vm-mime-get-header-contents "Content-ID:")
|
|
|
605 id (car (vm-mime-parse-content-header id))
|
|
|
606 description (vm-mime-get-header-contents
|
|
|
607 "Content-Description:")
|
|
|
608 description (and description (if (string-match "^[ \t\n]+$"
|
|
|
609 description)
|
|
|
610 nil
|
|
|
611 description))
|
|
|
612 disposition (vm-mime-get-header-contents
|
|
|
613 "Content-Disposition:")
|
|
24
|
614 qdisposition (and disposition
|
|
|
615 (vm-mime-parse-content-header
|
|
|
616 disposition ?\; t))
|
|
20
|
617 disposition (and disposition
|
|
|
618 (vm-mime-parse-content-header
|
|
|
619 disposition ?\;))))
|
|
|
620 (cond ((null m) t)
|
|
|
621 ((null version)
|
|
|
622 (throw 'return-value 'none))
|
|
114
|
623 ((or vm-mime-ignore-mime-version (string= version "1.0")) t)
|
|
20
|
624 (t (vm-mime-error "Unsupported MIME version: %s" version)))
|
|
|
625 (cond ((and m (null type))
|
|
|
626 (throw 'return-value
|
|
|
627 (vector '("text/plain" "charset=us-ascii")
|
|
24
|
628 '("text/plain" "charset=us-ascii")
|
|
|
629 encoding id description
|
|
|
630 disposition qdisposition
|
|
20
|
631 (vm-headers-of m)
|
|
|
632 (vm-text-of m)
|
|
|
633 (vm-text-end-of m)
|
|
146
|
634 nil nil nil )))
|
|
20
|
635 ((null type)
|
|
|
636 (goto-char (point-min))
|
|
|
637 (or (re-search-forward "^\n\\|\n\\'" nil t)
|
|
|
638 (vm-mime-error "MIME part missing header/body separator line"))
|
|
24
|
639 (vector default-type default-type
|
|
|
640 encoding id description
|
|
|
641 disposition qdisposition
|
|
20
|
642 (vm-marker (point-min))
|
|
|
643 (vm-marker (point))
|
|
|
644 (vm-marker (point-max))
|
|
146
|
645 nil nil nil ))
|
|
20
|
646 ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
|
|
|
647 (vm-mime-error "Malformed MIME content type: %s" (car type)))
|
|
|
648 ((and (string-match "^multipart/\\|^message/" (car type))
|
|
|
649 (null (string-match "^\\(7bit\\|8bit\\|binary\\)$"
|
|
|
650 encoding)))
|
|
|
651 (vm-mime-error "Opaque transfer encoding used with multipart or message type: %s, %s" (car type) encoding))
|
|
|
652 ((and (string-match "^message/partial$" (car type))
|
|
|
653 (null (string-match "^7bit$" encoding)))
|
|
|
654 (vm-mime-error "Non-7BIT transfer encoding used with message/partial message: %s" encoding))
|
|
|
655 ((string-match "^multipart/digest" (car type))
|
|
|
656 (setq c-t '("message/rfc822")
|
|
|
657 c-t-e "7bit"))
|
|
|
658 ((string-match "^multipart/" (car type))
|
|
|
659 (setq c-t '("text/plain" "charset=us-ascii")
|
|
|
660 c-t-e "7bit")) ; below
|
|
30
|
661 ((string-match "^message/\\(rfc822\\|news\\)" (car type))
|
|
20
|
662 (setq c-t '("text/plain" "charset=us-ascii")
|
|
|
663 c-t-e "7bit")
|
|
|
664 (goto-char (point-min))
|
|
|
665 (or (re-search-forward "^\n\\|\n\\'" nil t)
|
|
|
666 (vm-mime-error "MIME part missing header/body separator line"))
|
|
|
667 (throw 'return-value
|
|
24
|
668 (vector type qtype encoding id description
|
|
|
669 disposition qdisposition
|
|
20
|
670 (vm-marker (point-min))
|
|
|
671 (vm-marker (point))
|
|
|
672 (vm-marker (point-max))
|
|
|
673 (list
|
|
|
674 (save-restriction
|
|
|
675 (narrow-to-region (point) (point-max))
|
|
24
|
676 (vm-mime-parse-entity-safe nil c-t
|
|
|
677 c-t-e)))
|
|
146
|
678 nil nil )))
|
|
20
|
679 (t
|
|
|
680 (goto-char (point-min))
|
|
|
681 (or (re-search-forward "^\n\\|\n\\'" nil t)
|
|
|
682 (vm-mime-error "MIME part missing header/body separator line"))
|
|
|
683 (throw 'return-value
|
|
24
|
684 (vector type qtype encoding id description
|
|
|
685 disposition qdisposition
|
|
20
|
686 (vm-marker (point-min))
|
|
|
687 (vm-marker (point))
|
|
|
688 (vm-marker (point-max))
|
|
146
|
689 nil nil nil ))))
|
|
20
|
690 (setq p (cdr type)
|
|
|
691 boundary nil)
|
|
|
692 (while p
|
|
|
693 (if (string-match "^boundary=" (car p))
|
|
|
694 (setq boundary (car (vm-parse (car p) "=\\(.+\\)"))
|
|
|
695 p nil)
|
|
|
696 (setq p (cdr p))))
|
|
|
697 (or boundary
|
|
|
698 (vm-mime-error
|
|
|
699 "Boundary parameter missing in %s type specification"
|
|
|
700 (car type)))
|
|
24
|
701 ;; the \' in the regexp is to "be liberal" in the
|
|
|
702 ;; face of broken software that does not add a line
|
|
|
703 ;; break after the final boundary of a nested
|
|
|
704 ;; multipart entity.
|
|
|
705 (setq boundary-regexp
|
|
|
706 (concat "^--" (regexp-quote boundary)
|
|
|
707 "\\(--\\)?[ \t]*\\(\n\\|\\'\\)"))
|
|
20
|
708 (goto-char (point-min))
|
|
|
709 (setq start nil
|
|
|
710 multipart-list nil
|
|
|
711 done nil)
|
|
|
712 (while (and (not done) (re-search-forward boundary-regexp nil t))
|
|
|
713 (cond ((null start)
|
|
|
714 (setq start (match-end 0)))
|
|
|
715 (t
|
|
|
716 (and (match-beginning 1)
|
|
|
717 (setq done t))
|
|
|
718 (save-excursion
|
|
|
719 (save-restriction
|
|
|
720 (narrow-to-region start (1- (match-beginning 0)))
|
|
|
721 (setq start (match-end 0))
|
|
|
722 (setq multipart-list
|
|
|
723 (cons (vm-mime-parse-entity-safe nil c-t c-t-e)
|
|
|
724 multipart-list)))))))
|
|
|
725 (if (not done)
|
|
|
726 (vm-mime-error "final %s boundary missing" boundary))
|
|
|
727 (goto-char (point-min))
|
|
|
728 (or (re-search-forward "^\n\\|\n\\'" nil t)
|
|
|
729 (vm-mime-error "MIME part missing header/body separator line"))
|
|
24
|
730 (vector type qtype encoding id description
|
|
|
731 disposition qdisposition
|
|
20
|
732 (vm-marker (point-min))
|
|
|
733 (vm-marker (point))
|
|
|
734 (vm-marker (point-max))
|
|
|
735 (nreverse multipart-list)
|
|
146
|
736 nil nil )))))))
|
|
20
|
737
|
|
|
738 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e)
|
|
|
739 (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
|
|
|
740 ;; don't let subpart parse errors make the whole parse fail. use default
|
|
|
741 ;; type if the parse fails.
|
|
|
742 (condition-case error-data
|
|
|
743 (vm-mime-parse-entity nil c-t c-t-e)
|
|
|
744 (vm-mime-error
|
|
|
745 (let ((header (if m
|
|
|
746 (vm-headers-of m)
|
|
|
747 (vm-marker (point-min))))
|
|
|
748 (text (if m
|
|
|
749 (vm-text-of m)
|
|
|
750 (save-excursion
|
|
|
751 (re-search-forward "^\n\\|\n\\'"
|
|
|
752 nil 0)
|
|
|
753 (vm-marker (point)))))
|
|
|
754 (text-end (if m
|
|
|
755 (vm-text-end-of m)
|
|
|
756 (vm-marker (point-max)))))
|
|
24
|
757 (vector c-t c-t
|
|
20
|
758 (vm-determine-proper-content-transfer-encoding text text-end)
|
|
|
759 nil
|
|
|
760 ;; cram the error message into the description slot
|
|
24
|
761 (car (cdr error-data))
|
|
20
|
762 ;; mark as an attachment to improve the chance that the user
|
|
|
763 ;; will see the description.
|
|
24
|
764 '("attachment") '("attachment")
|
|
20
|
765 header
|
|
|
766 text
|
|
136
|
767 text-end
|
|
146
|
768 nil nil nil)))))
|
|
20
|
769
|
|
|
770 (defun vm-mime-get-xxx-parameter (layout name param-list)
|
|
|
771 (let ((match-end (1+ (length name)))
|
|
|
772 (name-regexp (concat (regexp-quote name) "="))
|
|
|
773 (case-fold-search t)
|
|
|
774 (done nil))
|
|
|
775 (while (and param-list (not done))
|
|
|
776 (if (and (string-match name-regexp (car param-list))
|
|
|
777 (= (match-end 0) match-end))
|
|
|
778 (setq done t)
|
|
|
779 (setq param-list (cdr param-list))))
|
|
|
780 (and (car param-list) (car (vm-parse (car param-list) "=\\(.*\\)")))))
|
|
|
781
|
|
|
782 (defun vm-mime-get-parameter (layout name)
|
|
|
783 (vm-mime-get-xxx-parameter layout name (cdr (vm-mm-layout-type layout))))
|
|
|
784
|
|
|
785 (defun vm-mime-get-disposition-parameter (layout name)
|
|
|
786 (vm-mime-get-xxx-parameter layout name
|
|
|
787 (cdr (vm-mm-layout-disposition layout))))
|
|
|
788
|
|
|
789 (defun vm-mime-insert-mime-body (layout)
|
|
|
790 (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout))
|
|
|
791 (vm-mm-layout-body-start layout)
|
|
|
792 (vm-mm-layout-body-end layout)))
|
|
|
793
|
|
|
794 (defun vm-mime-insert-mime-headers (layout)
|
|
|
795 (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout))
|
|
|
796 (vm-mm-layout-header-start layout)
|
|
|
797 (vm-mm-layout-body-start layout))
|
|
|
798 (if (and (not (bobp)) (char-equal (char-after (1- (point))) ?\n))
|
|
|
799 (delete-char -1)))
|
|
|
800
|
|
|
801 (defun vm-make-presentation-copy (m)
|
|
|
802 (let ((mail-buffer (current-buffer))
|
|
|
803 b mm
|
|
|
804 (real-m (vm-real-message-of m))
|
|
|
805 (modified (buffer-modified-p)))
|
|
|
806 (cond ((or (null vm-presentation-buffer-handle)
|
|
|
807 (null (buffer-name vm-presentation-buffer-handle)))
|
|
|
808 (setq b (generate-new-buffer (concat (buffer-name)
|
|
|
809 " Presentation")))
|
|
|
810 (save-excursion
|
|
|
811 (set-buffer b)
|
|
|
812 (if (fboundp 'buffer-disable-undo)
|
|
|
813 (buffer-disable-undo (current-buffer))
|
|
|
814 ;; obfuscation to make the v19 compiler not whine
|
|
|
815 ;; about obsolete functions.
|
|
|
816 (let ((x 'buffer-flush-undo))
|
|
|
817 (funcall x (current-buffer))))
|
|
|
818 (setq mode-name "VM Presentation"
|
|
|
819 major-mode 'vm-presentation-mode
|
|
|
820 vm-message-pointer (list nil)
|
|
|
821 vm-mail-buffer mail-buffer
|
|
|
822 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
|
|
|
823 (vm-menu-support-possible-p)
|
|
|
824 (vm-menu-mode-menu))
|
|
24
|
825 ;; Default to binary file type for DOS/NT.
|
|
|
826 buffer-file-type t
|
|
|
827 ;; Tell XEmacs/MULE not to mess with the text on writes.
|
|
20
|
828 buffer-read-only t
|
|
|
829 mode-line-format vm-mode-line-format)
|
|
30
|
830 ;; scroll in place messes with scroll-up and this loses
|
|
|
831 (defvar scroll-in-place)
|
|
|
832 (make-local-variable 'scroll-in-place)
|
|
|
833 (setq scroll-in-place nil)
|
|
120
|
834 (and vm-xemacs-mule-p
|
|
140
|
835 (set-buffer-file-coding-system 'binary t))
|
|
120
|
836 (cond (vm-fsfemacs-19-p
|
|
20
|
837 ;; need to do this outside the let because
|
|
|
838 ;; loading disp-table initializes
|
|
|
839 ;; standard-display-table.
|
|
|
840 (require 'disp-table)
|
|
|
841 (let* ((standard-display-table
|
|
|
842 (copy-sequence standard-display-table)))
|
|
|
843 (standard-display-european t)
|
|
|
844 (setq buffer-display-table standard-display-table))))
|
|
155
|
845 (if (and vm-mutable-frames vm-frame-per-folder
|
|
|
846 (vm-multiple-frames-possible-p))
|
|
20
|
847 (vm-set-hooks-for-frame-deletion))
|
|
|
848 (use-local-map vm-mode-map)
|
|
|
849 (and (vm-toolbar-support-possible-p) vm-use-toolbar
|
|
|
850 (vm-toolbar-install-toolbar))
|
|
|
851 (and (vm-menu-support-possible-p)
|
|
114
|
852 (vm-menu-install-menus))
|
|
|
853 (run-hooks 'vm-presentation-mode-hook))
|
|
20
|
854 (setq vm-presentation-buffer-handle b)))
|
|
|
855 (setq b vm-presentation-buffer-handle
|
|
|
856 vm-presentation-buffer vm-presentation-buffer-handle
|
|
|
857 vm-mime-decoded nil)
|
|
|
858 (save-excursion
|
|
|
859 (set-buffer (vm-buffer-of real-m))
|
|
|
860 (save-restriction
|
|
|
861 (widen)
|
|
|
862 ;; must reference this now so that headers will be in
|
|
|
863 ;; their final position before the message is copied.
|
|
|
864 ;; otherwise the vheader offset computed below will be
|
|
|
865 ;; wrong.
|
|
|
866 (vm-vheaders-of real-m)
|
|
|
867 (set-buffer b)
|
|
|
868 (widen)
|
|
|
869 (let ((buffer-read-only nil)
|
|
140
|
870 ;; disable read-only text properties
|
|
|
871 (inhibit-read-only t)
|
|
20
|
872 (modified (buffer-modified-p)))
|
|
|
873 (unwind-protect
|
|
|
874 (progn
|
|
|
875 (erase-buffer)
|
|
|
876 (insert-buffer-substring (vm-buffer-of real-m)
|
|
|
877 (vm-start-of real-m)
|
|
|
878 (vm-end-of real-m)))
|
|
|
879 (set-buffer-modified-p modified)))
|
|
|
880 (setq mm (copy-sequence m))
|
|
|
881 (vm-set-location-data-of mm (vm-copy (vm-location-data-of m)))
|
|
|
882 (set-marker (vm-start-of mm) (point-min))
|
|
|
883 (set-marker (vm-headers-of mm) (+ (vm-start-of mm)
|
|
|
884 (- (vm-headers-of real-m)
|
|
|
885 (vm-start-of real-m))))
|
|
|
886 (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm)
|
|
|
887 (- (vm-vheaders-of real-m)
|
|
|
888 (vm-start-of real-m))))
|
|
|
889 (set-marker (vm-text-of mm) (+ (vm-start-of mm)
|
|
|
890 (- (vm-text-of real-m)
|
|
|
891 (vm-start-of real-m))))
|
|
|
892 (set-marker (vm-text-end-of mm) (+ (vm-start-of mm)
|
|
|
893 (- (vm-text-end-of real-m)
|
|
|
894 (vm-start-of real-m))))
|
|
|
895 (set-marker (vm-end-of mm) (+ (vm-start-of mm)
|
|
|
896 (- (vm-end-of real-m)
|
|
|
897 (vm-start-of real-m))))
|
|
|
898 (setcar vm-message-pointer mm)))))
|
|
|
899
|
|
|
900 (fset 'vm-presentation-mode 'vm-mode)
|
|
|
901 (put 'vm-presentation-mode 'mode-class 'special)
|
|
|
902
|
|
140
|
903 (defvar buffer-file-coding-system)
|
|
24
|
904
|
|
20
|
905 (defun vm-determine-proper-charset (beg end)
|
|
|
906 (save-excursion
|
|
|
907 (save-restriction
|
|
|
908 (narrow-to-region beg end)
|
|
|
909 (catch 'done
|
|
|
910 (goto-char (point-min))
|
|
120
|
911 (if vm-xemacs-mule-p
|
|
24
|
912 (let ((charsets (delq 'ascii (charsets-in-region beg end))))
|
|
|
913 (cond ((null charsets)
|
|
|
914 "us-ascii")
|
|
|
915 ((cdr charsets)
|
|
|
916 (or (car (cdr
|
|
140
|
917 (assq (coding-system-name
|
|
|
918 buffer-file-coding-system)
|
|
|
919 vm-mime-mule-coding-to-charset-alist)))
|
|
24
|
920 "iso-2022-jp"))
|
|
|
921 (t
|
|
|
922 (or (car (cdr
|
|
30
|
923 (assoc
|
|
24
|
924 (car charsets)
|
|
|
925 vm-mime-mule-charset-to-charset-alist)))
|
|
|
926 "unknown"))))
|
|
|
927 (and (re-search-forward "[^\000-\177]" nil t)
|
|
|
928 (throw 'done (or vm-mime-8bit-composition-charset
|
|
|
929 "iso-8859-1")))
|
|
|
930 (throw 'done "us-ascii"))))))
|
|
20
|
931
|
|
|
932 (defun vm-determine-proper-content-transfer-encoding (beg end)
|
|
|
933 (save-excursion
|
|
|
934 (save-restriction
|
|
|
935 (narrow-to-region beg end)
|
|
|
936 (catch 'done
|
|
|
937 (goto-char (point-min))
|
|
|
938 (and (re-search-forward "[\000\015]" nil t)
|
|
|
939 (throw 'done "binary"))
|
|
|
940
|
|
|
941 (let ((toolong nil) bol)
|
|
|
942 (goto-char (point-min))
|
|
|
943 (setq bol (point))
|
|
|
944 (while (and (not (eobp)) (not toolong))
|
|
|
945 (forward-line)
|
|
|
946 (setq toolong (> (- (point) bol) 998)
|
|
|
947 bol (point)))
|
|
|
948 (and toolong (throw 'done "binary")))
|
|
|
949
|
|
|
950 (goto-char (point-min))
|
|
|
951 (and (re-search-forward "[\200-\377]" nil t)
|
|
|
952 (throw 'done "8bit"))
|
|
|
953
|
|
|
954 "7bit"))))
|
|
|
955
|
|
|
956 (defun vm-mime-types-match (type type/subtype)
|
|
|
957 (let ((case-fold-search t))
|
|
|
958 (cond ((string-match "/" type)
|
|
|
959 (if (and (string-match (regexp-quote type) type/subtype)
|
|
|
960 (equal 0 (match-beginning 0))
|
|
|
961 (equal (length type/subtype) (match-end 0)))
|
|
|
962 t
|
|
|
963 nil ))
|
|
|
964 ((and (string-match (regexp-quote type) type/subtype)
|
|
|
965 (equal 0 (match-beginning 0))
|
|
|
966 (equal (save-match-data
|
|
|
967 (string-match "/" type/subtype (match-end 0)))
|
|
|
968 (match-end 0)))))))
|
|
|
969
|
|
|
970 (defvar native-sound-only-on-console)
|
|
|
971
|
|
|
972 (defun vm-mime-can-display-internal (layout)
|
|
|
973 (let ((type (car (vm-mm-layout-type layout))))
|
|
|
974 (cond ((vm-mime-types-match "image/jpeg" type)
|
|
120
|
975 (and vm-xemacs-p
|
|
20
|
976 (featurep 'jpeg)
|
|
|
977 (eq (device-type) 'x)))
|
|
|
978 ((vm-mime-types-match "image/gif" type)
|
|
120
|
979 (and vm-xemacs-p
|
|
20
|
980 (featurep 'gif)
|
|
|
981 (eq (device-type) 'x)))
|
|
|
982 ((vm-mime-types-match "image/png" type)
|
|
120
|
983 (and vm-xemacs-p
|
|
20
|
984 (featurep 'png)
|
|
|
985 (eq (device-type) 'x)))
|
|
|
986 ((vm-mime-types-match "image/tiff" type)
|
|
120
|
987 (and vm-xemacs-p
|
|
20
|
988 (featurep 'tiff)
|
|
|
989 (eq (device-type) 'x)))
|
|
|
990 ((vm-mime-types-match "audio/basic" type)
|
|
120
|
991 (and vm-xemacs-p
|
|
20
|
992 (or (featurep 'native-sound)
|
|
|
993 (featurep 'nas-sound))
|
|
|
994 (or (device-sound-enabled-p)
|
|
|
995 (and (featurep 'native-sound)
|
|
|
996 (not native-sound-only-on-console)
|
|
|
997 (eq (device-type) 'x)))))
|
|
|
998 ((vm-mime-types-match "multipart" type) t)
|
|
|
999 ((vm-mime-types-match "message/external-body" type) nil)
|
|
|
1000 ((vm-mime-types-match "message" type) t)
|
|
|
1001 ((or (vm-mime-types-match "text/plain" type)
|
|
|
1002 (vm-mime-types-match "text/enriched" type))
|
|
|
1003 (let ((charset (or (vm-mime-get-parameter layout "charset")
|
|
|
1004 "us-ascii")))
|
|
|
1005 (vm-mime-charset-internally-displayable-p charset)))
|
|
120
|
1006 ((vm-mime-types-match "text/html" type)
|
|
|
1007 (condition-case ()
|
|
|
1008 (progn (require 'w3)
|
|
|
1009 (fboundp 'w3-region))
|
|
|
1010 (error nil)))
|
|
20
|
1011 (t nil))))
|
|
|
1012
|
|
|
1013 (defun vm-mime-can-convert (type)
|
|
|
1014 (let ((alist vm-mime-type-converter-alist)
|
|
|
1015 ;; fake layout. make it the wrong length so an error will
|
|
|
1016 ;; be signaled if vm-mime-can-display-internal ever asks
|
|
|
1017 ;; for one of the other fields
|
|
|
1018 (fake-layout (make-vector 1 (list nil)))
|
|
|
1019 (done nil))
|
|
|
1020 (while (and alist (not done))
|
|
|
1021 (cond ((and (vm-mime-types-match (car (car alist)) type)
|
|
|
1022 (or (progn
|
|
|
1023 (setcar (aref fake-layout 0) (nth 1 (car alist)))
|
|
|
1024 (vm-mime-can-display-internal fake-layout))
|
|
|
1025 (vm-mime-find-external-viewer (nth 1 (car alist)))))
|
|
|
1026 (setq done t))
|
|
|
1027 (t (setq alist (cdr alist)))))
|
|
|
1028 (and alist (car alist))))
|
|
|
1029
|
|
|
1030 (defun vm-mime-convert-undisplayable-layout (layout)
|
|
|
1031 (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout)))))
|
|
26
|
1032 (message "Converting %s to %s..."
|
|
20
|
1033 (car (vm-mm-layout-type layout))
|
|
|
1034 (nth 1 ooo))
|
|
|
1035 (save-excursion
|
|
|
1036 (set-buffer (generate-new-buffer " *mime object*"))
|
|
|
1037 (setq vm-message-garbage-alist
|
|
|
1038 (cons (cons (current-buffer) 'kill-buffer)
|
|
|
1039 vm-message-garbage-alist))
|
|
|
1040 (vm-mime-insert-mime-body layout)
|
|
|
1041 (vm-mime-transfer-decode-region layout (point-min) (point-max))
|
|
|
1042 (call-process-region (point-min) (point-max) shell-file-name
|
|
|
1043 t t nil shell-command-switch (nth 2 ooo))
|
|
|
1044 (goto-char (point-min))
|
|
|
1045 (insert "Content-Type: " (nth 1 ooo) "\n")
|
|
|
1046 (insert "Content-Transfer-Encoding: binary\n\n")
|
|
|
1047 (set-buffer-modified-p nil)
|
|
26
|
1048 (message "Converting %s to %s... done"
|
|
20
|
1049 (car (vm-mm-layout-type layout))
|
|
|
1050 (nth 1 ooo))
|
|
|
1051 (vector (list (nth 1 ooo))
|
|
24
|
1052 (list (nth 1 ooo))
|
|
20
|
1053 "binary"
|
|
|
1054 (vm-mm-layout-id layout)
|
|
|
1055 (vm-mm-layout-description layout)
|
|
|
1056 (vm-mm-layout-disposition layout)
|
|
24
|
1057 (vm-mm-layout-qdisposition layout)
|
|
20
|
1058 (vm-marker (point-min))
|
|
|
1059 (vm-marker (point))
|
|
|
1060 (vm-marker (point-max))
|
|
|
1061 nil
|
|
146
|
1062 nil
|
|
|
1063 nil))))
|
|
20
|
1064
|
|
|
1065 (defun vm-mime-should-display-button (layout dont-honor-content-disposition)
|
|
|
1066 (if (and vm-honor-mime-content-disposition
|
|
|
1067 (not dont-honor-content-disposition)
|
|
|
1068 (vm-mm-layout-disposition layout))
|
|
|
1069 (let ((case-fold-search t))
|
|
|
1070 (string-match "^attachment$" (car (vm-mm-layout-disposition layout))))
|
|
|
1071 (let ((i-list vm-auto-displayed-mime-content-types)
|
|
|
1072 (type (car (vm-mm-layout-type layout)))
|
|
|
1073 (matched nil))
|
|
|
1074 (if (eq i-list t)
|
|
|
1075 nil
|
|
|
1076 (while (and i-list (not matched))
|
|
|
1077 (if (vm-mime-types-match (car i-list) type)
|
|
|
1078 (setq matched t)
|
|
|
1079 (setq i-list (cdr i-list))))
|
|
|
1080 (not matched) ))))
|
|
|
1081
|
|
|
1082 (defun vm-mime-should-display-internal (layout dont-honor-content-disposition)
|
|
|
1083 (if (and vm-honor-mime-content-disposition
|
|
|
1084 (not dont-honor-content-disposition)
|
|
|
1085 (vm-mm-layout-disposition layout))
|
|
|
1086 (let ((case-fold-search t))
|
|
|
1087 (string-match "^inline$" (car (vm-mm-layout-disposition layout))))
|
|
|
1088 (let ((i-list vm-mime-internal-content-types)
|
|
|
1089 (type (car (vm-mm-layout-type layout)))
|
|
|
1090 (matched nil))
|
|
|
1091 (if (eq i-list t)
|
|
|
1092 t
|
|
|
1093 (while (and i-list (not matched))
|
|
|
1094 (if (vm-mime-types-match (car i-list) type)
|
|
|
1095 (setq matched t)
|
|
|
1096 (setq i-list (cdr i-list))))
|
|
|
1097 matched ))))
|
|
|
1098
|
|
|
1099 (defun vm-mime-find-external-viewer (type)
|
|
|
1100 (let ((e-alist vm-mime-external-content-types-alist)
|
|
|
1101 (matched nil))
|
|
|
1102 (while (and e-alist (not matched))
|
|
|
1103 (if (and (vm-mime-types-match (car (car e-alist)) type)
|
|
|
1104 (cdr (car e-alist)))
|
|
|
1105 (setq matched (cdr (car e-alist)))
|
|
|
1106 (setq e-alist (cdr e-alist))))
|
|
|
1107 matched ))
|
|
|
1108 (fset 'vm-mime-should-display-external 'vm-mime-find-external-viewer)
|
|
|
1109
|
|
|
1110 (defun vm-mime-delete-button-maybe (extent)
|
|
|
1111 (let ((buffer-read-only))
|
|
|
1112 ;; if displayed MIME object should replace the button
|
|
|
1113 ;; remove the button now.
|
|
|
1114 (cond ((vm-extent-property extent 'vm-mime-disposable)
|
|
|
1115 (delete-region (vm-extent-start-position extent)
|
|
|
1116 (vm-extent-end-position extent))
|
|
|
1117 (vm-detach-extent extent)))))
|
|
|
1118
|
|
|
1119 (defun vm-decode-mime-message ()
|
|
|
1120 "Decode the MIME objects in the current message.
|
|
|
1121
|
|
|
1122 The first time this command is run on a message, decoding is done.
|
|
|
1123 The second time, buttons for all the objects are displayed instead.
|
|
|
1124 The third time, the raw, undecoded data is displayed.
|
|
|
1125
|
|
|
1126 If decoding, the decoded objects might be displayed immediately, or
|
|
|
1127 buttons might be displayed that you need to activate to view the
|
|
|
1128 object. See the documentation for the variables
|
|
|
1129
|
|
|
1130 vm-auto-displayed-mime-content-types
|
|
|
1131 vm-mime-internal-content-types
|
|
|
1132 vm-mime-external-content-types-alist
|
|
|
1133
|
|
|
1134 to see how to control whether you see buttons or objects.
|
|
|
1135
|
|
|
1136 If the variable vm-mime-display-function is set, then its value
|
|
|
1137 is called as a function with no arguments, and none of the
|
|
|
1138 actions mentioned in the preceding paragraphs are done. At the
|
|
|
1139 time of the call, the current buffer will be the presentation
|
|
|
1140 buffer for the folder and a copy of the current message will be
|
|
|
1141 in the buffer. The function is expected to make the message
|
|
|
1142 `MIME presentable' to the user in whatever manner it sees fit."
|
|
|
1143 (interactive)
|
|
|
1144 (vm-follow-summary-cursor)
|
|
|
1145 (vm-select-folder-buffer)
|
|
|
1146 (vm-check-for-killed-summary)
|
|
|
1147 (vm-check-for-killed-presentation)
|
|
|
1148 (vm-error-if-folder-empty)
|
|
|
1149 (if (and (not vm-display-using-mime)
|
|
|
1150 (null vm-mime-display-function))
|
|
|
1151 (error "MIME display disabled, set vm-display-using-mime non-nil to enable."))
|
|
|
1152 (if vm-mime-display-function
|
|
|
1153 (progn
|
|
|
1154 (vm-make-presentation-copy (car vm-message-pointer))
|
|
|
1155 (set-buffer vm-presentation-buffer)
|
|
|
1156 (funcall vm-mime-display-function))
|
|
|
1157 (if vm-mime-decoded
|
|
|
1158 (if (eq vm-mime-decoded 'decoded)
|
|
|
1159 (let ((vm-preview-read-messages nil)
|
|
|
1160 (vm-auto-decode-mime-messages t)
|
|
|
1161 (vm-honor-mime-content-disposition nil)
|
|
|
1162 (vm-auto-displayed-mime-content-types '("multipart")))
|
|
|
1163 (setq vm-mime-decoded nil)
|
|
|
1164 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
1165 (save-excursion
|
|
|
1166 (vm-preview-current-message))
|
|
|
1167 (setq vm-mime-decoded 'buttons))
|
|
|
1168 (let ((vm-preview-read-messages nil)
|
|
|
1169 (vm-auto-decode-mime-messages nil))
|
|
|
1170 (intern (buffer-name) vm-buffers-needing-display-update)
|
|
|
1171 (vm-preview-current-message)))
|
|
|
1172 (let ((layout (vm-mm-layout (car vm-message-pointer)))
|
|
|
1173 (m (car vm-message-pointer)))
|
|
26
|
1174 (message "Decoding MIME message...")
|
|
20
|
1175 (cond ((stringp layout)
|
|
|
1176 (error "Invalid MIME message: %s" layout)))
|
|
|
1177 (if (vm-mime-plain-message-p m)
|
|
|
1178 (error "Message needs no decoding."))
|
|
|
1179 (or vm-presentation-buffer
|
|
|
1180 ;; maybe user killed it
|
|
|
1181 (error "No presentation buffer."))
|
|
|
1182 (set-buffer vm-presentation-buffer)
|
|
24
|
1183 (if (and (interactive-p) (eq vm-system-state 'previewing))
|
|
|
1184 (let ((vm-display-using-mime nil))
|
|
|
1185 (vm-show-current-message)))
|
|
20
|
1186 (setq m (car vm-message-pointer))
|
|
|
1187 (vm-save-restriction
|
|
|
1188 (widen)
|
|
|
1189 (goto-char (vm-text-of m))
|
|
|
1190 (let ((buffer-read-only nil)
|
|
|
1191 (modified (buffer-modified-p)))
|
|
|
1192 (unwind-protect
|
|
|
1193 (save-excursion
|
|
|
1194 (and (not (eq (vm-mm-encoded-header m) 'none))
|
|
|
1195 (vm-decode-mime-message-headers m))
|
|
|
1196 (if (vectorp layout)
|
|
|
1197 (progn
|
|
|
1198 (vm-decode-mime-layout layout)
|
|
114
|
1199 (delete-region (point) (point-max))))
|
|
|
1200 (vm-energize-urls)
|
|
|
1201 (vm-highlight-headers-maybe)
|
|
|
1202 (vm-energize-headers-and-xfaces))
|
|
20
|
1203 (set-buffer-modified-p modified))))
|
|
|
1204 (save-excursion (set-buffer vm-mail-buffer)
|
|
|
1205 (setq vm-mime-decoded 'decoded))
|
|
|
1206 (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update)
|
|
|
1207 (vm-update-summary-and-mode-line)
|
|
26
|
1208 (message "Decoding MIME message... done"))))
|
|
20
|
1209 (vm-display nil nil '(vm-decode-mime-message)
|
|
|
1210 '(vm-decode-mime-message reading-message)))
|
|
|
1211
|
|
|
1212 (defun vm-decode-mime-layout (layout &optional dont-honor-c-d)
|
|
|
1213 (let ((modified (buffer-modified-p)) type type-no-subtype (extent nil))
|
|
|
1214 (unwind-protect
|
|
|
1215 (progn
|
|
|
1216 (if (not (vectorp layout))
|
|
|
1217 (progn
|
|
|
1218 (setq extent layout
|
|
|
1219 layout (vm-extent-property extent 'vm-mime-layout))
|
|
|
1220 (goto-char (vm-extent-start-position extent))))
|
|
|
1221 (setq type (downcase (car (vm-mm-layout-type layout)))
|
|
|
1222 type-no-subtype (car (vm-parse type "\\([^/]+\\)")))
|
|
|
1223 (cond ((and (vm-mime-should-display-button layout dont-honor-c-d)
|
|
|
1224 (or (condition-case nil
|
|
|
1225 (funcall (intern
|
|
|
1226 (concat "vm-mime-display-button-"
|
|
|
1227 type))
|
|
|
1228 layout)
|
|
|
1229 (void-function nil))
|
|
|
1230 (condition-case nil
|
|
|
1231 (funcall (intern
|
|
|
1232 (concat "vm-mime-display-button-"
|
|
|
1233 type-no-subtype))
|
|
|
1234 layout)
|
|
|
1235 (void-function nil)))))
|
|
|
1236 ((and (vm-mime-should-display-internal layout dont-honor-c-d)
|
|
|
1237 (condition-case nil
|
|
|
1238 (funcall (intern
|
|
|
1239 (concat "vm-mime-display-internal-"
|
|
|
1240 type))
|
|
|
1241 layout)
|
|
|
1242 (void-function nil))))
|
|
|
1243 ((vm-mime-types-match "multipart" type)
|
|
|
1244 (or (condition-case nil
|
|
|
1245 (funcall (intern
|
|
|
1246 (concat "vm-mime-display-internal-"
|
|
|
1247 type))
|
|
|
1248 layout)
|
|
|
1249 (void-function nil))
|
|
|
1250 (vm-mime-display-internal-multipart/mixed layout)))
|
|
|
1251 ((and (vm-mime-should-display-external type)
|
|
|
1252 (vm-mime-display-external-generic layout))
|
|
|
1253 (and extent (vm-set-extent-property
|
|
|
1254 extent 'vm-mime-disposable nil)))
|
|
|
1255 ((vm-mime-can-convert type)
|
|
|
1256 (vm-decode-mime-layout
|
|
|
1257 (vm-mime-convert-undisplayable-layout layout)))
|
|
|
1258 ((and (or (vm-mime-types-match "message" type)
|
|
|
1259 (vm-mime-types-match "text" type))
|
|
|
1260 ;; display unmatched message and text types as
|
|
|
1261 ;; text/plain.
|
|
|
1262 (vm-mime-display-internal-text/plain layout)))
|
|
30
|
1263 (t (and extent (vm-mime-rewrite-failed-button
|
|
131
|
1264 extent
|
|
146
|
1265 (or (vm-mm-layout-display-error layout)
|
|
131
|
1266 "no external viewer defined for type")))
|
|
30
|
1267 (vm-mime-display-internal-application/octet-stream
|
|
20
|
1268 (or extent layout))))
|
|
|
1269 (and extent (vm-mime-delete-button-maybe extent)))
|
|
|
1270 (set-buffer-modified-p modified)))
|
|
|
1271 t )
|
|
|
1272
|
|
|
1273 (defun vm-mime-display-button-text (layout)
|
|
|
1274 (vm-mime-display-button-xxxx layout t))
|
|
|
1275
|
|
120
|
1276 (defun vm-mime-display-internal-text/html (layout)
|
|
131
|
1277 (if (fboundp 'w3-region)
|
|
|
1278 (let ((buffer-read-only nil)
|
|
|
1279 (work-buffer nil))
|
|
|
1280 (message "Inlining text/html, be patient...")
|
|
|
1281 ;; w3-region is not as tame as we would like.
|
|
|
1282 ;; make sure the yoke is firmly attached.
|
|
|
1283 (unwind-protect
|
|
|
1284 (progn
|
|
|
1285 (save-excursion
|
|
|
1286 (set-buffer (setq work-buffer
|
|
|
1287 (generate-new-buffer " *workbuf*")))
|
|
|
1288 (vm-mime-insert-mime-body layout)
|
|
|
1289 (vm-mime-transfer-decode-region layout (point-min) (point-max))
|
|
|
1290 (save-excursion
|
|
|
1291 (save-window-excursion
|
|
|
1292 (w3-region (point-min) (point-max)))))
|
|
|
1293 (insert-buffer-substring work-buffer))
|
|
|
1294 (and work-buffer (kill-buffer work-buffer)))
|
|
|
1295 (message "Inlining text/html... done")
|
|
|
1296 t )
|
|
146
|
1297 (vm-set-mm-layout-display-error layout "Need W3 to inline HTML")
|
|
131
|
1298 nil ))
|
|
20
|
1299
|
|
114
|
1300 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting)
|
|
24
|
1301 (let ((start (point)) end old-size
|
|
20
|
1302 (buffer-read-only nil)
|
|
|
1303 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
|
|
|
1304 (if (not (vm-mime-charset-internally-displayable-p charset))
|
|
30
|
1305 (progn
|
|
146
|
1306 (vm-set-mm-layout-display-error
|
|
30
|
1307 layout (concat "Undisplayable charset: " charset))
|
|
|
1308 nil)
|
|
20
|
1309 (vm-mime-insert-mime-body layout)
|
|
|
1310 (setq end (point-marker))
|
|
|
1311 (vm-mime-transfer-decode-region layout start end)
|
|
24
|
1312 (setq old-size (buffer-size))
|
|
20
|
1313 (vm-mime-charset-decode-region charset start end)
|
|
24
|
1314 (set-marker end (+ end (- (buffer-size) old-size)))
|
|
114
|
1315 (or no-highlighting (vm-energize-urls-in-message-region start end))
|
|
24
|
1316 (goto-char end)
|
|
20
|
1317 t )))
|
|
|
1318
|
|
|
1319 (defun vm-mime-display-internal-text/enriched (layout)
|
|
|
1320 (require 'enriched)
|
|
|
1321 (let ((start (point)) end
|
|
|
1322 (buffer-read-only nil)
|
|
|
1323 (enriched-verbose t))
|
|
26
|
1324 (message "Decoding text/enriched, be patient...")
|
|
20
|
1325 (vm-mime-insert-mime-body layout)
|
|
|
1326 (setq end (point-marker))
|
|
|
1327 (vm-mime-transfer-decode-region layout start end)
|
|
|
1328 ;; enriched-decode expects a couple of headers at the top of
|
|
|
1329 ;; the region and will remove anything that looks like a
|
|
|
1330 ;; header. Put a header section here for it to eat so it
|
|
|
1331 ;; won't eat message text instead.
|
|
|
1332 (goto-char start)
|
|
|
1333 (insert "Comment: You should not see this header\n\n")
|
|
|
1334 (enriched-decode start end)
|
|
|
1335 (vm-energize-urls-in-message-region start end)
|
|
|
1336 (goto-char end)
|
|
26
|
1337 (message "Decoding text/enriched... done")
|
|
20
|
1338 t ))
|
|
|
1339
|
|
|
1340 (defun vm-mime-display-external-generic (layout)
|
|
|
1341 (let ((program-list (vm-mime-find-external-viewer
|
|
|
1342 (car (vm-mm-layout-type layout))))
|
|
|
1343 (buffer-read-only nil)
|
|
|
1344 (start (point))
|
|
155
|
1345 process tempfile cache end)
|
|
|
1346 (setq cache (cdr (assq 'vm-mime-display-external-generic
|
|
|
1347 (vm-mm-layout-cache layout)))
|
|
|
1348 process (nth 0 cache)
|
|
|
1349 tempfile (nth 1 cache))
|
|
20
|
1350 (if (and (processp process) (eq (process-status process) 'run))
|
|
30
|
1351 t
|
|
20
|
1352 (cond ((or (null tempfile) (null (file-exists-p tempfile)))
|
|
|
1353 (vm-mime-insert-mime-body layout)
|
|
|
1354 (setq end (point-marker))
|
|
|
1355 (vm-mime-transfer-decode-region layout start end)
|
|
|
1356 (setq tempfile (vm-make-tempfile-name))
|
|
24
|
1357 (let ((buffer-file-type buffer-file-type)
|
|
140
|
1358 buffer-file-coding-system)
|
|
24
|
1359 ;; Tell DOS/Windows NT whether the file is binary
|
|
|
1360 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
|
|
|
1361 ;; Tell XEmacs/MULE not to mess with the bits unless
|
|
|
1362 ;; this is a text type.
|
|
120
|
1363 (if vm-xemacs-mule-p
|
|
24
|
1364 (if (vm-mime-text-type-p layout)
|
|
140
|
1365 (set-buffer-file-coding-system 'no-conversion nil)
|
|
|
1366 (set-buffer-file-coding-system 'binary t)))
|
|
146
|
1367 ;; Write an empty tempfile out to disk and set its
|
|
|
1368 ;; permissions to 0600, then write the actual buffer
|
|
|
1369 ;; contents to tempfile.
|
|
|
1370 (write-region start start tempfile nil 0)
|
|
|
1371 (set-file-modes tempfile 384)
|
|
24
|
1372 (write-region start end tempfile nil 0))
|
|
20
|
1373 (delete-region start end)
|
|
|
1374 (save-excursion
|
|
|
1375 (vm-select-folder-buffer)
|
|
|
1376 (setq vm-folder-garbage-alist
|
|
|
1377 (cons (cons tempfile 'delete-file)
|
|
|
1378 vm-folder-garbage-alist)))))
|
|
30
|
1379 (message "Launching %s..." (mapconcat 'identity program-list " "))
|
|
20
|
1380 (setq process
|
|
|
1381 (apply 'start-process
|
|
|
1382 (format "view %25s" (vm-mime-layout-description layout))
|
|
|
1383 nil (append program-list (list tempfile))))
|
|
|
1384 (process-kill-without-query process t)
|
|
26
|
1385 (message "Launching %s... done" (mapconcat 'identity
|
|
20
|
1386 program-list
|
|
|
1387 " "))
|
|
|
1388 (save-excursion
|
|
|
1389 (vm-select-folder-buffer)
|
|
|
1390 (setq vm-message-garbage-alist
|
|
|
1391 (cons (cons process 'delete-process)
|
|
|
1392 vm-message-garbage-alist)))
|
|
155
|
1393 (vm-set-mm-layout-cache
|
|
|
1394 layout
|
|
|
1395 (nconc (vm-mm-layout-cache layout)
|
|
|
1396 (list (cons 'vm-mime-display-external-generic
|
|
|
1397 (list process tempfile)))))))
|
|
20
|
1398 t )
|
|
|
1399
|
|
|
1400 (defun vm-mime-display-internal-application/octet-stream (layout)
|
|
|
1401 (if (vectorp layout)
|
|
|
1402 (let ((buffer-read-only nil)
|
|
|
1403 (description (vm-mm-layout-description layout)))
|
|
|
1404 (vm-mime-insert-button
|
|
24
|
1405 (format "%-35.35s [%s to save to a file]"
|
|
20
|
1406 (vm-mime-layout-description layout)
|
|
155
|
1407 (if (vm-mouse-support-possible-here-p)
|
|
20
|
1408 "Click mouse-2"
|
|
|
1409 "Press RETURN"))
|
|
|
1410 (function
|
|
|
1411 (lambda (layout)
|
|
|
1412 (save-excursion
|
|
|
1413 (vm-mime-display-internal-application/octet-stream layout))))
|
|
|
1414 layout nil))
|
|
|
1415 (goto-char (vm-extent-start-position layout))
|
|
|
1416 (setq layout (vm-extent-property layout 'vm-mime-layout))
|
|
|
1417 ;; support old "name" paramater for application/octet-stream
|
|
|
1418 ;; but don't override the "filename" parameter extracted from
|
|
|
1419 ;; Content-Disposition, if any.
|
|
|
1420 (let ((default-filename
|
|
|
1421 (if (vm-mime-get-disposition-parameter layout "filename")
|
|
|
1422 nil
|
|
|
1423 (vm-mime-get-parameter layout "name"))))
|
|
|
1424 (vm-mime-send-body-to-file layout default-filename)))
|
|
|
1425 t )
|
|
126
|
1426 (fset 'vm-mime-display-button-application/octet-stream
|
|
20
|
1427 'vm-mime-display-internal-application/octet-stream)
|
|
|
1428
|
|
126
|
1429 (defun vm-mime-display-button-application (layout)
|
|
|
1430 (vm-mime-display-button-xxxx layout nil))
|
|
|
1431
|
|
20
|
1432 (defun vm-mime-display-button-image (layout)
|
|
|
1433 (vm-mime-display-button-xxxx layout t))
|
|
|
1434
|
|
|
1435 (defun vm-mime-display-button-audio (layout)
|
|
|
1436 (vm-mime-display-button-xxxx layout nil))
|
|
|
1437
|
|
|
1438 (defun vm-mime-display-button-video (layout)
|
|
|
1439 (vm-mime-display-button-xxxx layout t))
|
|
|
1440
|
|
|
1441 (defun vm-mime-display-button-message (layout)
|
|
|
1442 (vm-mime-display-button-xxxx layout t))
|
|
|
1443
|
|
|
1444 (defun vm-mime-display-button-multipart (layout)
|
|
|
1445 (vm-mime-display-button-xxxx layout t))
|
|
|
1446
|
|
|
1447 (defun vm-mime-display-internal-multipart/mixed (layout)
|
|
|
1448 (let ((part-list (vm-mm-layout-parts layout)))
|
|
|
1449 (while part-list
|
|
|
1450 (vm-decode-mime-layout (car part-list))
|
|
|
1451 (setq part-list (cdr part-list)))
|
|
|
1452 t ))
|
|
|
1453
|
|
|
1454 (defun vm-mime-display-internal-multipart/alternative (layout)
|
|
|
1455 (let (best-layout)
|
|
|
1456 (cond ((eq vm-mime-alternative-select-method 'best)
|
|
|
1457 (let ((done nil)
|
|
|
1458 (best nil)
|
|
|
1459 part-list type)
|
|
|
1460 (setq part-list (vm-mm-layout-parts layout)
|
|
|
1461 part-list (nreverse (copy-sequence part-list)))
|
|
|
1462 (while (and part-list (not done))
|
|
|
1463 (setq type (car (vm-mm-layout-type (car part-list))))
|
|
|
1464 (if (or (vm-mime-can-display-internal (car part-list))
|
|
|
1465 (vm-mime-find-external-viewer type))
|
|
|
1466 (setq best (car part-list)
|
|
|
1467 done t)
|
|
|
1468 (setq part-list (cdr part-list))))
|
|
|
1469 (setq best-layout (or best (car (vm-mm-layout-parts layout))))))
|
|
|
1470 ((eq vm-mime-alternative-select-method 'best-internal)
|
|
|
1471 (let ((done nil)
|
|
|
1472 (best nil)
|
|
|
1473 (second-best nil)
|
|
|
1474 part-list type)
|
|
|
1475 (setq part-list (vm-mm-layout-parts layout)
|
|
|
1476 part-list (nreverse (copy-sequence part-list)))
|
|
|
1477 (while (and part-list (not done))
|
|
|
1478 (setq type (car (vm-mm-layout-type (car part-list))))
|
|
|
1479 (cond ((vm-mime-can-display-internal (car part-list))
|
|
|
1480 (setq best (car part-list)
|
|
|
1481 done t))
|
|
|
1482 ((and (null second-best)
|
|
|
1483 (vm-mime-find-external-viewer type))
|
|
|
1484 (setq second-best (car part-list))))
|
|
|
1485 (setq part-list (cdr part-list)))
|
|
|
1486 (setq best-layout (or best second-best
|
|
|
1487 (car (vm-mm-layout-parts layout)))))))
|
|
|
1488 (vm-decode-mime-layout best-layout)))
|
|
|
1489
|
|
|
1490 (defun vm-mime-display-button-multipart/parallel (layout)
|
|
|
1491 (vm-mime-insert-button
|
|
24
|
1492 (format "%-35.35s [%s to display in parallel]"
|
|
20
|
1493 (vm-mime-layout-description layout)
|
|
155
|
1494 (if (vm-mouse-support-possible-here-p)
|
|
20
|
1495 "Click mouse-2"
|
|
|
1496 "Press RETURN"))
|
|
|
1497 (function
|
|
|
1498 (lambda (layout)
|
|
|
1499 (save-excursion
|
|
|
1500 (let ((vm-auto-displayed-mime-content-types t))
|
|
|
1501 (vm-decode-mime-layout layout t)))))
|
|
|
1502 layout t))
|
|
|
1503
|
|
|
1504 (fset 'vm-mime-display-internal-multipart/parallel
|
|
|
1505 'vm-mime-display-internal-multipart/mixed)
|
|
|
1506
|
|
|
1507 (defun vm-mime-display-internal-multipart/digest (layout)
|
|
|
1508 (if (vectorp layout)
|
|
|
1509 (let ((buffer-read-only nil))
|
|
|
1510 (vm-mime-insert-button
|
|
24
|
1511 (format "%-35.35s [%s to display]"
|
|
20
|
1512 (vm-mime-layout-description layout)
|
|
155
|
1513 (if (vm-mouse-support-possible-here-p)
|
|
20
|
1514 "Click mouse-2"
|
|
|
1515 "Press RETURN"))
|
|
|
1516 (function
|
|
|
1517 (lambda (layout)
|
|
|
1518 (save-excursion
|
|
|
1519 (vm-mime-display-internal-multipart/digest layout))))
|
|
|
1520 layout nil))
|
|
|
1521 (goto-char (vm-extent-start-position layout))
|
|
|
1522 (setq layout (vm-extent-property layout 'vm-mime-layout))
|
|
|
1523 (set-buffer (generate-new-buffer (format "digest from %s/%s"
|
|
|
1524 (buffer-name vm-mail-buffer)
|
|
|
1525 (vm-number-of
|
|
|
1526 (car vm-message-pointer)))))
|
|
|
1527 (setq vm-folder-type vm-default-folder-type)
|
|
|
1528 (vm-mime-burst-layout layout nil)
|
|
|
1529 (vm-save-buffer-excursion
|
|
|
1530 (vm-goto-new-folder-frame-maybe 'folder)
|
|
|
1531 (vm-mode))
|
|
|
1532 ;; temp buffer, don't offer to save it.
|
|
|
1533 (setq buffer-offer-save nil)
|
|
114
|
1534 (vm-display (or vm-presentation-buffer (current-buffer)) t
|
|
|
1535 (list this-command) '(vm-mode startup)))
|
|
20
|
1536 t )
|
|
|
1537 (fset 'vm-mime-display-button-multipart/digest
|
|
|
1538 'vm-mime-display-internal-multipart/digest)
|
|
|
1539
|
|
118
|
1540 (defun vm-mime-display-button-message/rfc822 (layout)
|
|
|
1541 (let ((buffer-read-only nil))
|
|
|
1542 (vm-mime-insert-button
|
|
|
1543 (format "%-35.35s [%s to display]"
|
|
|
1544 (vm-mime-layout-description layout)
|
|
155
|
1545 (if (vm-mouse-support-possible-here-p)
|
|
118
|
1546 "Click mouse-2"
|
|
|
1547 "Press RETURN"))
|
|
|
1548 (function
|
|
|
1549 (lambda (layout)
|
|
|
1550 (save-excursion
|
|
|
1551 (vm-mime-display-internal-message/rfc822 layout))))
|
|
|
1552 layout nil)))
|
|
|
1553 (fset 'vm-mime-display-button-message/news
|
|
|
1554 'vm-mime-display-button-message/rfc822)
|
|
|
1555
|
|
20
|
1556 (defun vm-mime-display-internal-message/rfc822 (layout)
|
|
|
1557 (if (vectorp layout)
|
|
146
|
1558 (let ((start (point))
|
|
|
1559 (buffer-read-only nil))
|
|
|
1560 (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout)))
|
|
140
|
1561 (insert ?\n)
|
|
146
|
1562 (save-excursion
|
|
|
1563 (goto-char start)
|
|
|
1564 (vm-reorder-message-headers nil vm-visible-headers
|
|
|
1565 vm-invisible-header-regexp))
|
|
140
|
1566 (save-restriction
|
|
|
1567 (narrow-to-region start (point))
|
|
|
1568 (vm-decode-mime-encoded-words))
|
|
|
1569 (vm-mime-display-internal-multipart/mixed layout))
|
|
20
|
1570 (goto-char (vm-extent-start-position layout))
|
|
|
1571 (setq layout (vm-extent-property layout 'vm-mime-layout))
|
|
|
1572 (set-buffer (generate-new-buffer
|
|
|
1573 (format "message from %s/%s"
|
|
|
1574 (buffer-name vm-mail-buffer)
|
|
|
1575 (vm-number-of
|
|
|
1576 (car vm-message-pointer)))))
|
|
|
1577 (setq vm-folder-type vm-default-folder-type)
|
|
|
1578 (vm-mime-burst-layout layout nil)
|
|
|
1579 (set-buffer-modified-p nil)
|
|
|
1580 (vm-save-buffer-excursion
|
|
|
1581 (vm-goto-new-folder-frame-maybe 'folder)
|
|
|
1582 (vm-mode))
|
|
|
1583 ;; temp buffer, don't offer to save it.
|
|
|
1584 (setq buffer-offer-save nil)
|
|
|
1585 (vm-display (or vm-presentation-buffer (current-buffer)) t
|
|
|
1586 (list this-command) '(vm-mode startup)))
|
|
|
1587 t )
|
|
30
|
1588 (fset 'vm-mime-display-internal-message/news
|
|
|
1589 'vm-mime-display-internal-message/rfc822)
|
|
20
|
1590
|
|
|
1591 (defun vm-mime-display-internal-message/partial (layout)
|
|
|
1592 (if (vectorp layout)
|
|
|
1593 (let ((buffer-read-only nil)
|
|
|
1594 (number (vm-mime-get-parameter layout "number"))
|
|
|
1595 (total (vm-mime-get-parameter layout "total")))
|
|
|
1596 (vm-mime-insert-button
|
|
24
|
1597 (format "%-35.35s [%s to attempt assembly]"
|
|
20
|
1598 (concat (vm-mime-layout-description layout)
|
|
|
1599 (and number (concat ", part " number))
|
|
|
1600 (and number total (concat " of " total)))
|
|
155
|
1601 (if (vm-mouse-support-possible-here-p)
|
|
20
|
1602 "Click mouse-2"
|
|
|
1603 "Press RETURN"))
|
|
|
1604 (function
|
|
|
1605 (lambda (layout)
|
|
|
1606 (save-excursion
|
|
|
1607 (vm-mime-display-internal-message/partial layout))))
|
|
|
1608 layout nil))
|
|
26
|
1609 (message "Assembling message...")
|
|
20
|
1610 (let ((parts nil)
|
|
|
1611 (missing nil)
|
|
|
1612 (work-buffer nil)
|
|
|
1613 extent id o number total m i prev part-header-pos
|
|
|
1614 p-id p-number p-total p-list)
|
|
|
1615 (setq extent layout
|
|
|
1616 layout (vm-extent-property extent 'vm-mime-layout)
|
|
|
1617 id (vm-mime-get-parameter layout "id"))
|
|
|
1618 (if (null id)
|
|
|
1619 (vm-mime-error
|
|
|
1620 "message/partial message missing id parameter"))
|
|
|
1621 (save-excursion
|
|
|
1622 (set-buffer (marker-buffer (vm-mm-layout-body-start layout)))
|
|
|
1623 (save-excursion
|
|
|
1624 (save-restriction
|
|
|
1625 (widen)
|
|
|
1626 (goto-char (point-min))
|
|
|
1627 (while (and (search-forward id nil t)
|
|
|
1628 (setq m (vm-message-at-point)))
|
|
|
1629 (setq o (vm-mm-layout m))
|
|
|
1630 (if (not (vectorp o))
|
|
|
1631 nil
|
|
|
1632 (setq p-list (vm-mime-find-message/partials o id))
|
|
|
1633 (while p-list
|
|
|
1634 (setq p-id (vm-mime-get-parameter (car p-list) "id"))
|
|
|
1635 (setq p-total (vm-mime-get-parameter (car p-list) "total"))
|
|
|
1636 (if (null p-total)
|
|
|
1637 nil
|
|
|
1638 (setq p-total (string-to-int p-total))
|
|
|
1639 (if (< p-total 1)
|
|
|
1640 (vm-mime-error "message/partial specified part total < 0, %d" p-total))
|
|
|
1641 (if total
|
|
|
1642 (if (not (= total p-total))
|
|
|
1643 (vm-mime-error "message/partial speificed total differs between parts, (%d != %d)" p-total total))
|
|
|
1644 (setq total p-total)))
|
|
|
1645 (setq p-number (vm-mime-get-parameter (car p-list) "number"))
|
|
|
1646 (if (null p-number)
|
|
|
1647 (vm-mime-error
|
|
|
1648 "message/partial message missing number parameter"))
|
|
|
1649 (setq p-number (string-to-int p-number))
|
|
|
1650 (if (< p-number 1)
|
|
|
1651 (vm-mime-error "message/partial part number < 0, %d"
|
|
|
1652 p-number))
|
|
|
1653 (if (and total (> p-number total))
|
|
|
1654 (vm-mime-error "message/partial part number greater than expected number of parts, (%d > %d)" p-number total))
|
|
|
1655 (setq parts (cons (list p-number (car p-list)) parts)
|
|
|
1656 p-list (cdr p-list))))
|
|
|
1657 (goto-char (vm-mm-layout-body-end o))))))
|
|
|
1658 (if (null total)
|
|
|
1659 (vm-mime-error "total number of parts not specified in any message/partial part"))
|
|
|
1660 (setq parts (sort parts
|
|
|
1661 (function
|
|
|
1662 (lambda (p q)
|
|
|
1663 (< (car p)
|
|
|
1664 (car q))))))
|
|
|
1665 (setq i 0
|
|
|
1666 p-list parts)
|
|
|
1667 (while p-list
|
|
|
1668 (cond ((< i (car (car p-list)))
|
|
|
1669 (vm-increment i)
|
|
|
1670 (cond ((not (= i (car (car p-list))))
|
|
|
1671 (setq missing (cons i missing)))
|
|
|
1672 (t (setq prev p-list
|
|
|
1673 p-list (cdr p-list)))))
|
|
|
1674 (t
|
|
|
1675 ;; remove duplicate part
|
|
|
1676 (setcdr prev (cdr p-list))
|
|
|
1677 (setq p-list (cdr p-list)))))
|
|
|
1678 (while (< i total)
|
|
|
1679 (vm-increment i)
|
|
|
1680 (setq missing (cons i missing)))
|
|
|
1681 (if missing
|
|
|
1682 (vm-mime-error "part%s %s%s missing"
|
|
|
1683 (if (cdr missing) "s" "")
|
|
|
1684 (mapconcat
|
|
|
1685 (function identity)
|
|
|
1686 (nreverse (mapcar 'int-to-string
|
|
|
1687 (or (cdr missing) missing)))
|
|
|
1688 ", ")
|
|
|
1689 (if (cdr missing)
|
|
|
1690 (concat " and " (car missing))
|
|
|
1691 "")))
|
|
|
1692 (set-buffer (generate-new-buffer "assembled message"))
|
|
|
1693 (setq vm-folder-type vm-default-folder-type)
|
|
|
1694 (vm-mime-insert-mime-headers (car (cdr (car parts))))
|
|
|
1695 (goto-char (point-min))
|
|
|
1696 (vm-reorder-message-headers
|
|
|
1697 nil nil
|
|
|
1698 "\\(Encrypted\\|Content-\\|MIME-Version\\|Message-ID\\|Subject\\|X-VM-\\|Status\\)")
|
|
|
1699 (goto-char (point-max))
|
|
|
1700 (setq part-header-pos (point))
|
|
|
1701 (while parts
|
|
|
1702 (vm-mime-insert-mime-body (car (cdr (car parts))))
|
|
|
1703 (setq parts (cdr parts)))
|
|
|
1704 (goto-char part-header-pos)
|
|
|
1705 (vm-reorder-message-headers
|
|
|
1706 nil '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") nil)
|
|
|
1707 (vm-munge-message-separators vm-folder-type (point-min) (point-max))
|
|
|
1708 (goto-char (point-min))
|
|
|
1709 (insert (vm-leading-message-separator))
|
|
|
1710 (goto-char (point-max))
|
|
|
1711 (insert (vm-trailing-message-separator))
|
|
|
1712 (set-buffer-modified-p nil)
|
|
26
|
1713 (message "Assembling message... done")
|
|
20
|
1714 (vm-save-buffer-excursion
|
|
|
1715 (vm-goto-new-folder-frame-maybe 'folder)
|
|
|
1716 (vm-mode))
|
|
|
1717 ;; temp buffer, don't offer to save it.
|
|
|
1718 (setq buffer-offer-save nil)
|
|
|
1719 (vm-display (or vm-presentation-buffer (current-buffer)) t
|
|
|
1720 (list this-command) '(vm-mode startup)))
|
|
|
1721 t ))
|
|
|
1722 (fset 'vm-mime-display-button-message/partial
|
|
|
1723 'vm-mime-display-internal-message/partial)
|
|
|
1724
|
|
|
1725 (defun vm-mime-display-internal-image-xxxx (layout feature name)
|
|
120
|
1726 (if (and vm-xemacs-p
|
|
20
|
1727 (featurep feature)
|
|
|
1728 (eq (device-type) 'x))
|
|
|
1729 (let ((start (point)) end tempfile g e
|
|
|
1730 (buffer-read-only nil))
|
|
155
|
1731 (if (setq g (cdr (assq 'vm-mime-display-internal-image-xxxx
|
|
|
1732 (vm-mm-layout-cache layout))))
|
|
|
1733 nil
|
|
20
|
1734 (vm-mime-insert-mime-body layout)
|
|
|
1735 (setq end (point-marker))
|
|
|
1736 (vm-mime-transfer-decode-region layout start end)
|
|
|
1737 (setq tempfile (vm-make-tempfile-name))
|
|
146
|
1738 ;; Write an empty tempfile out to disk and set its
|
|
|
1739 ;; permissions to 0600, then write the actual buffer
|
|
|
1740 ;; contents to tempfile.
|
|
|
1741 (write-region start start tempfile nil 0)
|
|
|
1742 (set-file-modes tempfile 384)
|
|
|
1743 ;; coding system for presentation buffer is binary so
|
|
|
1744 ;; we don't need to set it here.
|
|
20
|
1745 (write-region start end tempfile nil 0)
|
|
26
|
1746 (message "Creating %s glyph..." name)
|
|
20
|
1747 (setq g (make-glyph
|
|
155
|
1748 (list
|
|
|
1749 (cons (list 'win)
|
|
|
1750 (vector feature ':file tempfile))
|
|
|
1751 (cons (list 'win)
|
|
|
1752 (vector 'string
|
|
|
1753 ':data
|
|
175
|
1754 (format "[Unknown/Bad %s image encoding]\n"
|
|
155
|
1755 name)))
|
|
|
1756 (cons nil
|
|
|
1757 (vector 'string
|
|
|
1758 ':data
|
|
|
1759 (format "[%s image]\n" name))))))
|
|
26
|
1760 (message "")
|
|
155
|
1761 (vm-set-mm-layout-cache
|
|
|
1762 layout
|
|
|
1763 (nconc (vm-mm-layout-cache layout)
|
|
|
1764 (list (cons 'vm-mime-display-internal-image-xxxx g))))
|
|
20
|
1765 (save-excursion
|
|
|
1766 (vm-select-folder-buffer)
|
|
|
1767 (setq vm-folder-garbage-alist
|
|
|
1768 (cons (cons tempfile 'delete-file)
|
|
|
1769 vm-folder-garbage-alist)))
|
|
|
1770 (delete-region start end))
|
|
|
1771 (if (not (bolp))
|
|
|
1772 (insert-char ?\n 2)
|
|
|
1773 (insert-char ?\n 1))
|
|
|
1774 (setq e (vm-make-extent (1- (point)) (point)))
|
|
|
1775 (vm-set-extent-property e 'begin-glyph g)
|
|
|
1776 t )))
|
|
|
1777
|
|
|
1778 (defun vm-mime-display-internal-image/gif (layout)
|
|
|
1779 (vm-mime-display-internal-image-xxxx layout 'gif "GIF"))
|
|
|
1780
|
|
|
1781 (defun vm-mime-display-internal-image/jpeg (layout)
|
|
|
1782 (vm-mime-display-internal-image-xxxx layout 'jpeg "JPEG"))
|
|
|
1783
|
|
|
1784 (defun vm-mime-display-internal-image/png (layout)
|
|
|
1785 (vm-mime-display-internal-image-xxxx layout 'png "PNG"))
|
|
|
1786
|
|
|
1787 (defun vm-mime-display-internal-image/tiff (layout)
|
|
|
1788 (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF"))
|
|
|
1789
|
|
|
1790 (defun vm-mime-display-internal-audio/basic (layout)
|
|
120
|
1791 (if (and vm-xemacs-p
|
|
20
|
1792 (or (featurep 'native-sound)
|
|
|
1793 (featurep 'nas-sound))
|
|
|
1794 (or (device-sound-enabled-p)
|
|
|
1795 (and (featurep 'native-sound)
|
|
|
1796 (not native-sound-only-on-console)
|
|
|
1797 (eq (device-type) 'x))))
|
|
|
1798 (let ((start (point)) end tempfile
|
|
|
1799 (buffer-read-only nil))
|
|
155
|
1800 (if (setq tempfile (cdr (assq 'vm-mime-display-internal-audio/basic
|
|
|
1801 (vm-mm-layout-cache layout))))
|
|
|
1802 nil
|
|
20
|
1803 (vm-mime-insert-mime-body layout)
|
|
|
1804 (setq end (point-marker))
|
|
|
1805 (vm-mime-transfer-decode-region layout start end)
|
|
|
1806 (setq tempfile (vm-make-tempfile-name))
|
|
146
|
1807 ;; Write an empty tempfile out to disk and set its
|
|
|
1808 ;; permissions to 0600, then write the actual buffer
|
|
|
1809 ;; contents to tempfile.
|
|
|
1810 (write-region start start tempfile nil 0)
|
|
|
1811 (set-file-modes tempfile 384)
|
|
|
1812 ;; coding system for presentation buffer is binary, so
|
|
|
1813 ;; we don't need to set it here.
|
|
20
|
1814 (write-region start end tempfile nil 0)
|
|
155
|
1815 (vm-set-mm-layout-cache
|
|
|
1816 layout
|
|
|
1817 (nconc (vm-mm-layout-cache layout)
|
|
|
1818 (list (cons 'vm-mime-display-internal-audio/basic
|
|
|
1819 tempfile))))
|
|
20
|
1820 (save-excursion
|
|
|
1821 (vm-select-folder-buffer)
|
|
|
1822 (setq vm-folder-garbage-alist
|
|
|
1823 (cons (cons tempfile 'delete-file)
|
|
|
1824 vm-folder-garbage-alist)))
|
|
|
1825 (delete-region start end))
|
|
|
1826 (start-itimer "audioplayer"
|
|
|
1827 (list 'lambda nil (list 'play-sound-file tempfile))
|
|
|
1828 1)
|
|
|
1829 t )
|
|
|
1830 nil ))
|
|
|
1831
|
|
|
1832 (defun vm-mime-display-button-xxxx (layout disposable)
|
|
|
1833 (let ((description (vm-mime-layout-description layout)))
|
|
|
1834 (vm-mime-insert-button
|
|
131
|
1835 (format "%-35.35s [%s to attempt display]"
|
|
20
|
1836 description
|
|
155
|
1837 (if (vm-mouse-support-possible-here-p)
|
|
|
1838 "Click mouse-2"
|
|
|
1839 "Press RETURN"))
|
|
20
|
1840 (function
|
|
|
1841 (lambda (layout)
|
|
|
1842 (save-excursion
|
|
|
1843 (let ((vm-auto-displayed-mime-content-types t))
|
|
|
1844 (vm-decode-mime-layout layout t)))))
|
|
|
1845 layout disposable)
|
|
|
1846 t ))
|
|
|
1847
|
|
30
|
1848 (defun vm-mime-run-display-function-at-point (&optional function dispose)
|
|
20
|
1849 (interactive)
|
|
|
1850 ;; save excursion to keep point from moving. its motion would
|
|
|
1851 ;; drag window point along, to a place arbitrarily far from
|
|
|
1852 ;; where it was when the user triggered the button.
|
|
|
1853 (save-excursion
|
|
120
|
1854 (cond (vm-fsfemacs-19-p
|
|
20
|
1855 (let (o-list o (found nil))
|
|
|
1856 (setq o-list (overlays-at (point)))
|
|
|
1857 (while (and o-list (not found))
|
|
|
1858 (cond ((overlay-get (car o-list) 'vm-mime-layout)
|
|
|
1859 (setq found t)
|
|
|
1860 (funcall (or function (overlay-get (car o-list)
|
|
|
1861 'vm-mime-function))
|
|
|
1862 (car o-list))))
|
|
|
1863 (setq o-list (cdr o-list)))))
|
|
120
|
1864 (vm-xemacs-p
|
|
20
|
1865 (let ((e (extent-at (point) nil 'vm-mime-layout)))
|
|
|
1866 (funcall (or function (extent-property e 'vm-mime-function))
|
|
|
1867 e))))))
|
|
|
1868
|
|
|
1869 ;; for the karking compiler
|
|
|
1870 (defvar vm-menu-mime-dispose-menu)
|
|
|
1871
|
|
120
|
1872 (defun vm-mime-set-extent-glyph-for-type (e type)
|
|
126
|
1873 (if (and vm-xemacs-p
|
|
|
1874 (featurep 'xpm)
|
|
|
1875 (eq (device-type) 'x)
|
|
|
1876 (> (device-bitplanes) 7))
|
|
120
|
1877 (let ((dir vm-image-directory)
|
|
118
|
1878 (colorful (> (device-bitplanes) 15))
|
|
|
1879 (tuples
|
|
|
1880 '(("text" "document-simple.xpm" "document-colorful.xpm")
|
|
126
|
1881 ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm")
|
|
118
|
1882 ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm")
|
|
|
1883 ("video" "film-simple.xpm" "film-colorful.xpm")
|
|
|
1884 ("message" "message-simple.xpm" "message-colorful.xpm")
|
|
|
1885 ("application" "gear-simple.xpm" "gear-colorful.xpm")
|
|
|
1886 ("multipart" "stuffed_box-simple.xpm"
|
|
|
1887 "stuffed_box-colorful.xpm")))
|
|
|
1888 glyph file sym p)
|
|
|
1889 (setq file (catch 'done
|
|
|
1890 (while tuples
|
|
|
1891 (if (vm-mime-types-match (car (car tuples)) type)
|
|
|
1892 (throw 'done (car tuples))
|
|
|
1893 (setq tuples (cdr tuples))))
|
|
|
1894 nil)
|
|
120
|
1895 file (and file (if colorful (nth 2 file) (nth 1 file)))
|
|
118
|
1896 sym (and file (intern file vm-image-obarray))
|
|
|
1897 glyph (and sym (boundp sym) (symbol-value sym))
|
|
136
|
1898 glyph (or glyph
|
|
|
1899 (and file
|
|
|
1900 (make-glyph
|
|
175
|
1901 (list
|
|
|
1902 (vector 'xpm ':file
|
|
|
1903 (expand-file-name file dir))
|
|
|
1904 [nothing])))))
|
|
118
|
1905 (and sym (not (boundp sym)) (set sym glyph))
|
|
24
|
1906 (and glyph (set-extent-begin-glyph e glyph)))))
|
|
|
1907
|
|
20
|
1908 (defun vm-mime-insert-button (caption action layout disposable)
|
|
|
1909 (let ((start (point)) e
|
|
|
1910 (keymap (make-sparse-keymap))
|
|
|
1911 (buffer-read-only nil))
|
|
|
1912 (if (fboundp 'set-keymap-parents)
|
|
30
|
1913 (if (current-local-map)
|
|
|
1914 (set-keymap-parents keymap (list (current-local-map))))
|
|
20
|
1915 (setq keymap (nconc keymap (current-local-map))))
|
|
|
1916 (define-key keymap "\r" 'vm-mime-run-display-function-at-point)
|
|
|
1917 (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3)
|
|
|
1918 (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu))
|
|
|
1919 (if (not (bolp))
|
|
|
1920 (insert "\n"))
|
|
|
1921 (insert caption "\n")
|
|
120
|
1922 ;; we must use the same interface that the vm-extent functions
|
|
|
1923 ;; use. if they use overlays, then we call make-overlay.
|
|
|
1924 (if (eq (symbol-function 'vm-make-extent) 'make-overlay)
|
|
|
1925 ;; we MUST have the five arg make-overlay. overlays must
|
|
|
1926 ;; advance when text is inserted at their start position or
|
|
|
1927 ;; inline text and graphics will seep into the button
|
|
|
1928 ;; overlay and then be removed when the button is removed.
|
|
20
|
1929 (setq e (make-overlay start (point) nil t nil))
|
|
|
1930 (setq e (make-extent start (point)))
|
|
|
1931 (set-extent-property e 'start-open t)
|
|
|
1932 (set-extent-property e 'end-open t))
|
|
120
|
1933 (vm-mime-set-extent-glyph-for-type e (car (vm-mm-layout-type layout)))
|
|
20
|
1934 ;; for emacs
|
|
|
1935 (vm-set-extent-property e 'mouse-face 'highlight)
|
|
|
1936 (vm-set-extent-property e 'local-map keymap)
|
|
|
1937 ;; for xemacs
|
|
|
1938 (vm-set-extent-property e 'highlight t)
|
|
|
1939 (vm-set-extent-property e 'keymap keymap)
|
|
|
1940 (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help)
|
|
|
1941 ;; for all
|
|
|
1942 (vm-set-extent-property e 'vm-mime-disposable disposable)
|
|
|
1943 (vm-set-extent-property e 'face vm-mime-button-face)
|
|
|
1944 (vm-set-extent-property e 'vm-mime-layout layout)
|
|
|
1945 (vm-set-extent-property e 'vm-mime-function action)))
|
|
|
1946
|
|
30
|
1947 (defun vm-mime-rewrite-failed-button (button error-string)
|
|
|
1948 (let* ((buffer-read-only nil)
|
|
|
1949 (start (point)))
|
|
|
1950 (goto-char (vm-extent-start-position button))
|
|
131
|
1951 (insert (format "DISPLAY FAILED -- %s\n" error-string))
|
|
30
|
1952 (vm-set-extent-endpoints button start (vm-extent-end-position button))
|
|
|
1953 (delete-region (point) (vm-extent-end-position button))))
|
|
|
1954
|
|
20
|
1955 (defun vm-mime-send-body-to-file (layout &optional default-filename)
|
|
|
1956 (if (not (vectorp layout))
|
|
|
1957 (setq layout (vm-extent-property layout 'vm-mime-layout)))
|
|
|
1958 (or default-filename
|
|
|
1959 (setq default-filename
|
|
|
1960 (vm-mime-get-disposition-parameter layout "filename")))
|
|
|
1961 (and default-filename
|
|
|
1962 (setq default-filename (file-name-nondirectory default-filename)))
|
|
|
1963 (let ((work-buffer nil)
|
|
24
|
1964 ;; evade the XEmacs dialog box, yeccch.
|
|
|
1965 (use-dialog-box nil)
|
|
|
1966 (dir vm-mime-attachment-save-directory)
|
|
|
1967 (done nil)
|
|
20
|
1968 file)
|
|
24
|
1969 (while (not done)
|
|
|
1970 (setq file
|
|
|
1971 (read-file-name
|
|
|
1972 (if default-filename
|
|
|
1973 (format "Write MIME body to file (default %s): "
|
|
|
1974 default-filename)
|
|
|
1975 "Write MIME body to file: ")
|
|
|
1976 dir default-filename)
|
|
|
1977 file (expand-file-name file dir))
|
|
|
1978 (if (not (file-directory-p file))
|
|
|
1979 (setq done t)
|
|
|
1980 (if default-filename
|
|
|
1981 (message "%s is a directory" file)
|
|
|
1982 (error "%s is a directory" file))
|
|
|
1983 (sit-for 2)
|
|
|
1984 (setq dir file
|
|
|
1985 default-filename (if (string-match "/$" file)
|
|
|
1986 (concat file default-filename)
|
|
|
1987 (concat file "/" default-filename)))))
|
|
20
|
1988 (save-excursion
|
|
|
1989 (unwind-protect
|
|
|
1990 (progn
|
|
|
1991 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
1992 (buffer-disable-undo work-buffer)
|
|
|
1993 (set-buffer work-buffer)
|
|
|
1994 ;; Tell DOS/Windows NT whether the file is binary
|
|
|
1995 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
|
|
24
|
1996 ;; Tell XEmacs/MULE not to mess with the bits unless
|
|
|
1997 ;; this is a text type.
|
|
120
|
1998 (if vm-xemacs-mule-p
|
|
24
|
1999 (if (vm-mime-text-type-p layout)
|
|
140
|
2000 (set-buffer-file-coding-system 'no-conversion nil)
|
|
|
2001 (set-buffer-file-coding-system 'binary t)))
|
|
20
|
2002 (vm-mime-insert-mime-body layout)
|
|
|
2003 (vm-mime-transfer-decode-region layout (point-min) (point-max))
|
|
|
2004 (or (not (file-exists-p file))
|
|
|
2005 (y-or-n-p "File exists, overwrite? ")
|
|
|
2006 (error "Aborted"))
|
|
|
2007 (write-region (point-min) (point-max) file nil nil))
|
|
|
2008 (and work-buffer (kill-buffer work-buffer))))))
|
|
|
2009
|
|
30
|
2010 (defun vm-mime-pipe-body-to-command (command layout &optional discard-output)
|
|
20
|
2011 (if (not (vectorp layout))
|
|
|
2012 (setq layout (vm-extent-property layout 'vm-mime-layout)))
|
|
30
|
2013 (let ((output-buffer (if discard-output
|
|
20
|
2014 0
|
|
|
2015 (get-buffer-create "*Shell Command Output*")))
|
|
|
2016 (work-buffer nil))
|
|
|
2017 (save-excursion
|
|
|
2018 (if (bufferp output-buffer)
|
|
|
2019 (progn
|
|
|
2020 (set-buffer output-buffer)
|
|
|
2021 (erase-buffer)))
|
|
|
2022 (unwind-protect
|
|
|
2023 (progn
|
|
|
2024 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
2025 (buffer-disable-undo work-buffer)
|
|
|
2026 (set-buffer work-buffer)
|
|
|
2027 (vm-mime-insert-mime-body layout)
|
|
|
2028 (vm-mime-transfer-decode-region layout (point-min) (point-max))
|
|
|
2029 (let ((pop-up-windows (and pop-up-windows
|
|
|
2030 (eq vm-mutable-windows t)))
|
|
|
2031 ;; Tell DOS/Windows NT whether the input is binary
|
|
|
2032 (binary-process-input (not (vm-mime-text-type-p layout))))
|
|
|
2033 (call-process-region (point-min) (point-max)
|
|
|
2034 (or shell-file-name "sh")
|
|
|
2035 nil output-buffer nil
|
|
30
|
2036 shell-command-switch command)))
|
|
20
|
2037 (and work-buffer (kill-buffer work-buffer)))
|
|
|
2038 (if (bufferp output-buffer)
|
|
|
2039 (progn
|
|
|
2040 (set-buffer output-buffer)
|
|
|
2041 (if (not (zerop (buffer-size)))
|
|
|
2042 (vm-display output-buffer t (list this-command)
|
|
|
2043 '(vm-pipe-message-to-command))
|
|
|
2044 (vm-display nil nil (list this-command)
|
|
|
2045 '(vm-pipe-message-to-command)))))))
|
|
|
2046 t )
|
|
|
2047
|
|
30
|
2048 (defun vm-mime-pipe-body-to-queried-command (layout &optional discard-output)
|
|
|
2049 (let ((command (read-string "Pipe to command: ")))
|
|
|
2050 (vm-mime-pipe-body-to-command command layout discard-output)))
|
|
|
2051
|
|
|
2052 (defun vm-mime-pipe-body-to-queried-command-discard-output (layout)
|
|
|
2053 (vm-mime-pipe-body-to-queried-command layout t))
|
|
|
2054
|
|
|
2055 (defun vm-mime-send-body-to-printer (layout)
|
|
|
2056 (vm-mime-pipe-body-to-command (mapconcat (function identity)
|
|
|
2057 (nconc (list vm-print-command)
|
|
|
2058 vm-print-command-switches)
|
|
|
2059 " ")
|
|
|
2060 layout))
|
|
|
2061
|
|
|
2062 (defun vm-mime-display-body-as-text (button)
|
|
|
2063 (let ((vm-auto-displayed-mime-content-types '("text/plain"))
|
|
|
2064 (layout (copy-sequence (vm-extent-property button 'vm-mime-layout))))
|
|
|
2065 (vm-set-extent-property button 'vm-mime-disposable t)
|
|
|
2066 (vm-set-extent-property button 'vm-mime-layout layout)
|
|
|
2067 ;; not universally correct, but close enough.
|
|
|
2068 (vm-set-mm-layout-type layout '("text/plain" "charset=us-ascii"))
|
|
|
2069 (goto-char (vm-extent-start-position button))
|
|
|
2070 (vm-decode-mime-layout button t)))
|
|
|
2071
|
|
|
2072 (defun vm-mime-display-body-using-external-viewer (button)
|
|
|
2073 (let ((layout (vm-extent-property button 'vm-mime-layout)))
|
|
|
2074 (goto-char (vm-extent-start-position button))
|
|
|
2075 (if (not (vm-mime-find-external-viewer (car (vm-mm-layout-type layout))))
|
|
|
2076 (error "No viewer defined for type %s"
|
|
|
2077 (car (vm-mm-layout-type layout)))
|
|
|
2078 (vm-mime-display-external-generic layout))))
|
|
20
|
2079
|
|
|
2080 (defun vm-mime-scrub-description (string)
|
|
|
2081 (let ((work-buffer nil))
|
|
|
2082 (save-excursion
|
|
|
2083 (unwind-protect
|
|
|
2084 (progn
|
|
|
2085 (setq work-buffer (generate-new-buffer " *vm-work*"))
|
|
|
2086 (buffer-disable-undo work-buffer)
|
|
|
2087 (set-buffer work-buffer)
|
|
|
2088 (insert string)
|
|
|
2089 (while (re-search-forward "[ \t\n]+" nil t)
|
|
|
2090 (replace-match " "))
|
|
|
2091 (buffer-string))
|
|
|
2092 (and work-buffer (kill-buffer work-buffer))))))
|
|
|
2093
|
|
|
2094 (defun vm-mime-layout-description (layout)
|
|
26
|
2095 (let ((type (car (vm-mm-layout-type layout)))
|
|
|
2096 description name)
|
|
|
2097 (setq description
|
|
|
2098 (if (vm-mm-layout-description layout)
|
|
|
2099 (vm-mime-scrub-description (vm-mm-layout-description layout))))
|
|
|
2100 (concat
|
|
|
2101 (if description description "")
|
|
|
2102 (if description ", " "")
|
|
|
2103 (cond ((vm-mime-types-match "multipart/digest" type)
|
|
|
2104 (let ((n (length (vm-mm-layout-parts layout))))
|
|
|
2105 (format "digest (%d message%s)" n (if (= n 1) "" "s"))))
|
|
|
2106 ((vm-mime-types-match "multipart/alternative" type)
|
|
|
2107 "multipart alternative")
|
|
|
2108 ((vm-mime-types-match "multipart" type)
|
|
|
2109 (let ((n (length (vm-mm-layout-parts layout))))
|
|
|
2110 (format "multipart message (%d part%s)" n (if (= n 1) "" "s"))))
|
|
|
2111 ((vm-mime-types-match "text/plain" type)
|
|
|
2112 (format "plain text%s"
|
|
|
2113 (let ((charset (vm-mime-get-parameter layout "charset")))
|
|
|
2114 (if charset
|
|
|
2115 (concat ", " charset)
|
|
|
2116 ""))))
|
|
|
2117 ((vm-mime-types-match "text/enriched" type)
|
|
|
2118 "enriched text")
|
|
|
2119 ((vm-mime-types-match "text/html" type)
|
|
|
2120 "HTML")
|
|
|
2121 ((vm-mime-types-match "image/gif" type)
|
|
|
2122 "GIF image")
|
|
|
2123 ((vm-mime-types-match "image/jpeg" type)
|
|
|
2124 "JPEG image")
|
|
|
2125 ((and (vm-mime-types-match "application/octet-stream" type)
|
|
|
2126 (setq name (vm-mime-get-parameter layout "name"))
|
|
|
2127 (save-match-data (not (string-match "^[ \t]*$" name))))
|
|
|
2128 name)
|
|
|
2129 (t type)))))
|
|
20
|
2130
|
|
|
2131 (defun vm-mime-layout-contains-type (layout type)
|
|
|
2132 (if (vm-mime-types-match type (car (vm-mm-layout-type layout)))
|
|
|
2133 layout
|
|
|
2134 (let ((p (vm-mm-layout-parts layout))
|
|
|
2135 (result nil)
|
|
|
2136 (done nil))
|
|
|
2137 (while (and p (not done))
|
|
|
2138 (if (setq result (vm-mime-layout-contains-type (car p) type))
|
|
|
2139 (setq done t)
|
|
|
2140 (setq p (cdr p))))
|
|
|
2141 result )))
|
|
146
|
2142
|
|
|
2143 ;; breadth first traversal
|
|
|
2144 (defun vm-mime-find-digests-in-layout (layout)
|
|
|
2145 (let ((layout-list (list layout))
|
|
|
2146 layout-type
|
|
|
2147 (result nil))
|
|
|
2148 (while layout-list
|
|
|
2149 (setq layout-type (car (vm-mm-layout-type (car layout-list))))
|
|
|
2150 (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)"
|
|
|
2151 layout-type)
|
|
|
2152 (setq result (nconc result (list (car layout-list)))))
|
|
|
2153 ((vm-mime-composite-type-p layout-type)
|
|
|
2154 (setq layout-list (nconc layout-list
|
|
|
2155 (copy-sequence
|
|
|
2156 (vm-mm-layout-parts
|
|
|
2157 (car layout-list)))))))
|
|
|
2158 (setq layout-list (cdr layout-list)))
|
|
|
2159 result ))
|
|
20
|
2160
|
|
|
2161 (defun vm-mime-plain-message-p (m)
|
|
|
2162 (save-match-data
|
|
|
2163 (let ((o (vm-mm-layout m))
|
|
|
2164 (case-fold-search t))
|
|
|
2165 (and (eq (vm-mm-encoded-header m) 'none)
|
|
|
2166 (or (not (vectorp o))
|
|
|
2167 (and (vm-mime-types-match "text/plain"
|
|
|
2168 (car (vm-mm-layout-type o)))
|
|
24
|
2169 (let* ((charset (or (vm-mime-get-parameter o "charset")
|
|
|
2170 "us-ascii")))
|
|
|
2171 (vm-string-member charset vm-mime-default-face-charsets))
|
|
20
|
2172 (string-match "^\\(7bit\\|8bit\\|binary\\)$"
|
|
|
2173 (vm-mm-layout-encoding o))))))))
|
|
|
2174
|
|
|
2175 (defun vm-mime-text-type-p (layout)
|
|
|
2176 (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout)))
|
|
|
2177 (vm-mime-types-match "message" (car (vm-mm-layout-type layout)))))
|
|
|
2178
|
|
|
2179 (defun vm-mime-charset-internally-displayable-p (name)
|
|
120
|
2180 (cond ((and vm-xemacs-mule-p (eq (device-type) 'x))
|
|
24
|
2181 (vm-string-assoc name vm-mime-mule-charset-to-coding-alist))
|
|
|
2182 ((vm-multiple-fonts-possible-p)
|
|
|
2183 (or (vm-string-member name vm-mime-default-face-charsets)
|
|
|
2184 (vm-string-assoc name vm-mime-charset-font-alist)))
|
|
|
2185 (t
|
|
|
2186 (vm-string-member name vm-mime-default-face-charsets))))
|
|
20
|
2187
|
|
|
2188 (defun vm-mime-find-message/partials (layout id)
|
|
|
2189 (let ((list nil)
|
|
|
2190 (type (vm-mm-layout-type layout)))
|
|
|
2191 (cond ((vm-mime-types-match "multipart" (car type))
|
|
|
2192 (let ((parts (vm-mm-layout-parts layout)) o)
|
|
|
2193 (while parts
|
|
|
2194 (setq o (vm-mime-find-message/partials (car parts) id))
|
|
|
2195 (if o
|
|
|
2196 (setq list (nconc o list)))
|
|
|
2197 (setq parts (cdr parts)))))
|
|
|
2198 ((vm-mime-types-match "message/partial" (car type))
|
|
|
2199 (if (equal (vm-mime-get-parameter layout "id") id)
|
|
|
2200 (setq list (cons layout list)))))
|
|
|
2201 list ))
|
|
|
2202
|
|
|
2203 (defun vm-message-at-point ()
|
|
|
2204 (let ((mp vm-message-list)
|
|
|
2205 (point (point))
|
|
|
2206 (done nil))
|
|
|
2207 (while (and mp (not done))
|
|
|
2208 (if (and (>= point (vm-start-of (car mp)))
|
|
|
2209 (<= point (vm-end-of (car mp))))
|
|
|
2210 (setq done t)
|
|
|
2211 (setq mp (cdr mp))))
|
|
|
2212 (car mp)))
|
|
|
2213
|
|
|
2214 (defun vm-mime-make-multipart-boundary ()
|
|
120
|
2215 (let ((boundary (make-string 10 ?a))
|
|
20
|
2216 (i 0))
|
|
|
2217 (random t)
|
|
|
2218 (while (< i (length boundary))
|
|
|
2219 (aset boundary i (aref vm-mime-base64-alphabet
|
|
|
2220 (% (vm-abs (lsh (random) -8))
|
|
|
2221 (length vm-mime-base64-alphabet))))
|
|
|
2222 (vm-increment i))
|
|
|
2223 boundary ))
|
|
|
2224
|
|
24
|
2225 (defun vm-mime-attach-file (file type &optional charset description)
|
|
20
|
2226 "Attach a file to a VM composition buffer to be sent along with the message.
|
|
|
2227 The file is not inserted into the buffer and MIME encoded until
|
|
|
2228 you execute vm-mail-send or vm-mail-send-and-exit. A visible tag
|
|
|
2229 indicating the existence of the attachment is placed in the
|
|
|
2230 composition buffer. You can move the attachment around or remove
|
|
|
2231 it entirely with normal text editing commands. If you remove the
|
|
|
2232 attachment tag, the attachment will not be sent.
|
|
|
2233
|
|
|
2234 First argument, FILE, is the name of the file to attach. Second
|
|
|
2235 argument, TYPE, is the MIME Content-Type of the file. Optional
|
|
|
2236 third argument CHARSET is the character set of the attached
|
|
24
|
2237 document. This argument is only used for text types, and it is
|
|
|
2238 ignored for other types. Optional fourth argument DESCRIPTION
|
|
|
2239 should be a one line description of the file.
|
|
20
|
2240
|
|
|
2241 When called interactively all arguments are read from the
|
|
|
2242 minibuffer.
|
|
|
2243
|
|
|
2244 This command is for attaching files that do not have a MIME
|
|
|
2245 header section at the top. For files with MIME headers, you
|
|
|
2246 should use vm-mime-attach-mime-file to attach such a file. VM
|
|
|
2247 will extract the content type information from the headers in
|
|
|
2248 this case and not prompt you for it in the minibuffer."
|
|
|
2249 (interactive
|
|
|
2250 ;; protect value of last-command and this-command
|
|
|
2251 (let ((last-command last-command)
|
|
|
2252 (this-command this-command)
|
|
|
2253 (charset nil)
|
|
24
|
2254 description file default-type type)
|
|
20
|
2255 (if (null vm-send-using-mime)
|
|
|
2256 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
|
|
|
2257 (setq file (vm-read-file-name "Attach file: " nil nil t)
|
|
|
2258 default-type (or (vm-mime-default-type-from-filename file)
|
|
|
2259 "application/octet-stream")
|
|
|
2260 type (completing-read
|
|
|
2261 (format "Content type (default %s): "
|
|
|
2262 default-type)
|
|
|
2263 vm-mime-type-completion-alist)
|
|
|
2264 type (if (> (length type) 0) type default-type))
|
|
|
2265 (if (vm-mime-types-match "text" type)
|
|
|
2266 (setq charset (completing-read "Character set (default US-ASCII): "
|
|
|
2267 vm-mime-charset-completion-alist)
|
|
|
2268 charset (if (> (length charset) 0) charset)))
|
|
24
|
2269 (setq description (read-string "One line description: "))
|
|
|
2270 (if (string-match "^[ \t]*$" description)
|
|
|
2271 (setq description nil))
|
|
|
2272 (list file type charset description)))
|
|
20
|
2273 (if (null vm-send-using-mime)
|
|
|
2274 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
|
|
|
2275 (if (file-directory-p file)
|
|
|
2276 (error "%s is a directory, cannot attach" file))
|
|
|
2277 (if (not (file-exists-p file))
|
|
|
2278 (error "No such file: %s" file))
|
|
|
2279 (if (not (file-readable-p file))
|
|
|
2280 (error "You don't have permission to read %s" file))
|
|
|
2281 (and charset (setq charset (list (concat "charset=" charset))))
|
|
24
|
2282 (and description (setq description (vm-mime-scrub-description description)))
|
|
|
2283 (vm-mime-attach-object file type charset description nil))
|
|
20
|
2284
|
|
|
2285 (defun vm-mime-attach-mime-file (file)
|
|
|
2286 "Attach a MIME encoded file to a VM composition buffer to be sent
|
|
|
2287 along with the message.
|
|
|
2288
|
|
|
2289 The file is not inserted into the buffer until you execute
|
|
|
2290 vm-mail-send or vm-mail-send-and-exit. A visible tag indicating
|
|
|
2291 the existence of the attachment is placed in the composition
|
|
|
2292 buffer. You can move the attachment around or remove it entirely
|
|
|
2293 with normal text editing commands. If you remove the attachment
|
|
|
2294 tag, the attachment will not be sent.
|
|
|
2295
|
|
|
2296 The sole argument, FILE, is the name of the file to attach.
|
|
|
2297 When called interactively the FILE argument is read from the
|
|
|
2298 minibuffer.
|
|
|
2299
|
|
|
2300 This command is for attaching files that have a MIME
|
|
|
2301 header section at the top. For files without MIME headers, you
|
|
|
2302 should use vm-mime-attach-file to attach such a file. VM
|
|
|
2303 will interactively query you for the file type information."
|
|
|
2304 (interactive
|
|
|
2305 ;; protect value of last-command and this-command
|
|
|
2306 (let ((last-command last-command)
|
|
|
2307 (this-command this-command)
|
|
|
2308 file)
|
|
|
2309 (if (null vm-send-using-mime)
|
|
|
2310 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
|
|
|
2311 (setq file (vm-read-file-name "Attach file: " nil nil t))
|
|
|
2312 (list file)))
|
|
|
2313 (if (null vm-send-using-mime)
|
|
|
2314 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
|
|
|
2315 (if (file-directory-p file)
|
|
|
2316 (error "%s is a directory, cannot attach" file))
|
|
|
2317 (if (not (file-exists-p file))
|
|
|
2318 (error "No such file: %s" file))
|
|
|
2319 (if (not (file-readable-p file))
|
|
|
2320 (error "You don't have permission to read %s" file))
|
|
24
|
2321 (vm-mime-attach-object file nil nil nil t))
|
|
20
|
2322
|
|
24
|
2323 (defun vm-mime-attach-object (object type params description mimed)
|
|
20
|
2324 (if (not (eq major-mode 'mail-mode))
|
|
|
2325 (error "Command must be used in a VM Mail mode buffer."))
|
|
24
|
2326 (let (start end e tag-string disposition)
|
|
|
2327 (if (< (point) (save-excursion (mail-text) (point)))
|
|
|
2328 (mail-text))
|
|
|
2329 (setq start (point)
|
|
|
2330 tag-string (format "[ATTACHMENT %s, %s]" object
|
|
|
2331 (or type "MIME file")))
|
|
20
|
2332 (insert tag-string "\n")
|
|
24
|
2333 (setq end (1- (point)))
|
|
|
2334 (if (and (stringp object) (not mimed))
|
|
|
2335 (progn
|
|
|
2336 (if (or (vm-mime-types-match "application" type)
|
|
|
2337 (vm-mime-types-match "model" type))
|
|
|
2338 (setq disposition (list "attachment"))
|
|
|
2339 (setq disposition (list "inline")))
|
|
|
2340 (setq disposition (nconc disposition
|
|
|
2341 (list
|
|
|
2342 (concat "filename=\""
|
|
|
2343 (file-name-nondirectory object)
|
|
30
|
2344 "\"")))))
|
|
|
2345 (setq disposition (list "unspecified")))
|
|
120
|
2346 (cond (vm-fsfemacs-19-p
|
|
24
|
2347 (put-text-property start end 'front-sticky nil)
|
|
|
2348 (put-text-property start end 'rear-nonsticky t)
|
|
30
|
2349 ;; can't be intangible because menu clicking at a position needs
|
|
|
2350 ;; to set point inside the tag so that a command can access the
|
|
|
2351 ;; text properties there.
|
|
|
2352 ;; (put-text-property start end 'intangible object)
|
|
24
|
2353 (put-text-property start end 'face vm-mime-button-face)
|
|
|
2354 (put-text-property start end 'vm-mime-type type)
|
|
|
2355 (put-text-property start end 'vm-mime-object object)
|
|
|
2356 (put-text-property start end 'vm-mime-parameters params)
|
|
|
2357 (put-text-property start end 'vm-mime-description description)
|
|
|
2358 (put-text-property start end 'vm-mime-disposition disposition)
|
|
|
2359 (put-text-property start end 'vm-mime-encoded mimed)
|
|
|
2360 (put-text-property start end 'vm-mime-object object))
|
|
120
|
2361 (vm-xemacs-p
|
|
24
|
2362 (setq e (make-extent start end))
|
|
126
|
2363 (vm-mime-set-extent-glyph-for-type e (or type "text/plain"))
|
|
20
|
2364 (set-extent-property e 'start-open t)
|
|
24
|
2365 (set-extent-property e 'face vm-mime-button-face)
|
|
118
|
2366 (set-extent-property e 'duplicable t)
|
|
30
|
2367 (let ((keymap (make-sparse-keymap)))
|
|
|
2368 (if vm-popup-menu-on-mouse-3
|
|
|
2369 (define-key keymap 'button3
|
|
|
2370 'vm-menu-popup-content-disposition-menu))
|
|
118
|
2371 (set-extent-property e 'keymap keymap)
|
|
30
|
2372 (set-extent-property e 'balloon-help 'vm-mouse-3-help))
|
|
118
|
2373 (set-extent-property e 'vm-mime-type type)
|
|
|
2374 (set-extent-property e 'vm-mime-object object)
|
|
|
2375 (set-extent-property e 'vm-mime-parameters params)
|
|
|
2376 (set-extent-property e 'vm-mime-description description)
|
|
|
2377 (set-extent-property e 'vm-mime-disposition disposition)
|
|
|
2378 (set-extent-property e 'vm-mime-encoded mimed)))))
|
|
24
|
2379
|
|
30
|
2380 (defun vm-mime-attachment-disposition-at-point ()
|
|
120
|
2381 (cond (vm-fsfemacs-19-p
|
|
30
|
2382 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
|
|
|
2383 (intern (car disp))))
|
|
120
|
2384 (vm-xemacs-p
|
|
30
|
2385 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
|
|
|
2386 (disp (extent-property e 'vm-mime-disposition)))
|
|
|
2387 (intern (car disp))))))
|
|
|
2388
|
|
|
2389 (defun vm-mime-set-attachment-disposition-at-point (sym)
|
|
120
|
2390 (cond (vm-fsfemacs-19-p
|
|
30
|
2391 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
|
|
|
2392 (setcar disp (symbol-name sym))))
|
|
120
|
2393 (vm-xemacs-p
|
|
30
|
2394 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
|
|
|
2395 (disp (extent-property e 'vm-mime-disposition)))
|
|
|
2396 (setcar disp (symbol-name sym))))))
|
|
|
2397
|
|
24
|
2398 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end
|
|
|
2399 &optional old-size)
|
|
|
2400 (cond ((null after) nil)
|
|
|
2401 ((= start (overlay-start overlay))
|
|
|
2402 (move-overlay overlay end (overlay-end overlay)))
|
|
|
2403 ((= start (overlay-end overlay))
|
|
|
2404 (move-overlay overlay (overlay-start overlay) start))))
|
|
|
2405
|
|
|
2406 (defun vm-mime-fake-attachment-overlays (start end)
|
|
|
2407 (let ((o-list nil)
|
|
|
2408 (done nil)
|
|
|
2409 (pos start)
|
|
26
|
2410 object props o)
|
|
24
|
2411 (save-excursion
|
|
|
2412 (save-restriction
|
|
|
2413 (narrow-to-region start end)
|
|
|
2414 (while (not done)
|
|
|
2415 (setq object (get-text-property pos 'vm-mime-object))
|
|
|
2416 (setq pos (next-single-property-change pos 'vm-mime-object))
|
|
|
2417 (or pos (setq pos (point-max) done t))
|
|
|
2418 (if object
|
|
|
2419 (progn
|
|
|
2420 (setq o (make-overlay start pos))
|
|
|
2421 (overlay-put o 'insert-in-front-hooks
|
|
|
2422 '(vm-disallow-overlay-endpoint-insertion))
|
|
|
2423 (overlay-put o 'insert-behind-hooks
|
|
|
2424 '(vm-disallow-overlay-endpoint-insertion))
|
|
|
2425 (setq props (text-properties-at start))
|
|
|
2426 (while props
|
|
|
2427 (overlay-put o (car props) (car (cdr props)))
|
|
|
2428 (setq props (cdr (cdr props))))
|
|
|
2429 (setq o-list (cons o o-list))))
|
|
|
2430 (setq start pos))
|
|
|
2431 o-list ))))
|
|
20
|
2432
|
|
|
2433 (defun vm-mime-default-type-from-filename (file)
|
|
|
2434 (let ((alist vm-mime-attachment-auto-type-alist)
|
|
|
2435 (case-fold-search t)
|
|
|
2436 (done nil))
|
|
|
2437 (while (and alist (not done))
|
|
|
2438 (if (string-match (car (car alist)) file)
|
|
|
2439 (setq done t)
|
|
|
2440 (setq alist (cdr alist))))
|
|
|
2441 (and alist (cdr (car alist)))))
|
|
|
2442
|
|
|
2443 (defun vm-remove-mail-mode-header-separator ()
|
|
|
2444 (save-excursion
|
|
|
2445 (goto-char (point-min))
|
|
|
2446 (if (re-search-forward (concat "^" mail-header-separator "$") nil t)
|
|
|
2447 (progn
|
|
|
2448 (delete-region (match-beginning 0) (match-end 0))
|
|
|
2449 t )
|
|
|
2450 nil )))
|
|
|
2451
|
|
|
2452 (defun vm-add-mail-mode-header-separator ()
|
|
|
2453 (save-excursion
|
|
|
2454 (goto-char (point-min))
|
|
|
2455 (if (re-search-forward "^$" nil t)
|
|
|
2456 (replace-match mail-header-separator t t))))
|
|
|
2457
|
|
|
2458 (defun vm-mime-transfer-encode-region (encoding beg end crlf)
|
|
30
|
2459 (let ((case-fold-search t)
|
|
|
2460 (armor-from (and vm-mime-composition-armor-from-lines
|
|
|
2461 (let ((case-fold-search nil))
|
|
|
2462 (save-excursion
|
|
|
2463 (goto-char beg)
|
|
155
|
2464 (re-search-forward "^From " nil t)))))
|
|
|
2465 (armor-dot (let ((case-fold-search nil))
|
|
|
2466 (save-excursion
|
|
|
2467 (goto-char beg)
|
|
|
2468 (re-search-forward "^\\.\\n" nil t)))))
|
|
20
|
2469 (cond ((string-match "^binary$" encoding)
|
|
|
2470 (vm-mime-base64-encode-region beg end crlf)
|
|
|
2471 (setq encoding "base64"))
|
|
155
|
2472 ((and (not armor-from) (not armor-dot)
|
|
|
2473 (string-match "^7bit$" encoding)) t)
|
|
20
|
2474 ((string-match "^base64$" encoding) t)
|
|
|
2475 ((string-match "^quoted-printable$" encoding) t)
|
|
|
2476 ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable)
|
|
30
|
2477 (vm-mime-qp-encode-region beg end nil armor-from)
|
|
20
|
2478 (setq encoding "quoted-printable"))
|
|
|
2479 ((eq vm-mime-8bit-text-transfer-encoding 'base64)
|
|
|
2480 (vm-mime-base64-encode-region beg end crlf)
|
|
|
2481 (setq encoding "base64"))
|
|
30
|
2482 (armor-from (vm-mime-qp-encode-region beg end nil armor-from))
|
|
|
2483 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t))
|
|
20
|
2484 encoding ))
|
|
|
2485
|
|
|
2486 (defun vm-mime-transfer-encode-layout (layout)
|
|
136
|
2487 (let ((list (vm-mm-layout-parts layout))
|
|
|
2488 (type (car (vm-mm-layout-type layout)))
|
|
|
2489 (encoding "7bit")
|
|
|
2490 (vm-mime-8bit-text-transfer-encoding
|
|
|
2491 vm-mime-8bit-text-transfer-encoding))
|
|
|
2492 (cond ((vm-mime-composite-type-p type)
|
|
|
2493 ;; MIME messages of type "message" and
|
|
|
2494 ;; "multipart" are required to have a non-opaque
|
|
|
2495 ;; content transfer encoding. This means that
|
|
|
2496 ;; if the user only wants to send out 7bit data,
|
|
|
2497 ;; then any subpart that contains 8bit data must
|
|
|
2498 ;; have an opaque (qp or base64) 8->7bit
|
|
|
2499 ;; conversion performed on it so that the
|
|
|
2500 ;; enclosing entity can use a non-opaque
|
|
|
2501 ;; encoding.
|
|
|
2502 ;;
|
|
|
2503 ;; message/partial requires a "7bit" encoding so
|
|
|
2504 ;; force 8->7 conversion in that case.
|
|
|
2505 (cond ((memq vm-mime-8bit-text-transfer-encoding
|
|
|
2506 '(quoted-printable base64))
|
|
|
2507 t)
|
|
|
2508 ((vm-mime-types-match "message/partial" type)
|
|
|
2509 (setq vm-mime-8bit-text-transfer-encoding
|
|
|
2510 'quoted-printable)))
|
|
|
2511 (while list
|
|
|
2512 (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit")
|
|
|
2513 (setq encoding "8bit"))
|
|
|
2514 (setq list (cdr list))))
|
|
|
2515 (t
|
|
|
2516 (if (and (vm-mime-types-match "message/partial" type)
|
|
|
2517 (not (memq vm-mime-8bit-text-transfer-encoding
|
|
|
2518 '(quoted-printable base64))))
|
|
|
2519 (setq vm-mime-8bit-text-transfer-encoding
|
|
|
2520 'quoted-printable))
|
|
|
2521 (setq encoding
|
|
|
2522 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
|
|
|
2523 (vm-mm-layout-body-start layout)
|
|
|
2524 (vm-mm-layout-body-end layout)
|
|
|
2525 (vm-mime-text-type-p layout)))))
|
|
|
2526 (save-excursion
|
|
|
2527 (save-restriction
|
|
|
2528 (goto-char (vm-mm-layout-header-start layout))
|
|
|
2529 (narrow-to-region (point) (vm-mm-layout-body-start layout))
|
|
|
2530 (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
|
|
|
2531 (if (not (equal encoding "7bit"))
|
|
|
2532 (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n"))
|
|
|
2533 encoding ))))
|
|
24
|
2534
|
|
20
|
2535 (defun vm-mime-encode-composition ()
|
|
118
|
2536 "MIME encode the current mail composition buffer.
|
|
20
|
2537 Attachment tags added to the buffer with vm-mime-attach-file are expanded
|
|
|
2538 and the approriate content-type and boundary markup information is added."
|
|
|
2539 (interactive)
|
|
120
|
2540 (cond (vm-xemacs-mule-p
|
|
118
|
2541 (vm-mime-xemacs-encode-composition))
|
|
120
|
2542 (vm-xemacs-p
|
|
118
|
2543 (vm-mime-xemacs-encode-composition))
|
|
120
|
2544 (vm-fsfemacs-19-p
|
|
118
|
2545 (vm-mime-fsfemacs-encode-composition))
|
|
|
2546 (t
|
|
|
2547 (error "don't know how to MIME encode composition for %s"
|
|
|
2548 (emacs-version)))))
|
|
|
2549
|
|
140
|
2550 (defvar enriched-mode)
|
|
|
2551
|
|
118
|
2552 (defun vm-mime-xemacs-encode-composition ()
|
|
20
|
2553 (save-restriction
|
|
|
2554 (widen)
|
|
|
2555 (if (not (eq major-mode 'mail-mode))
|
|
|
2556 (error "Command must be used in a VM Mail mode buffer."))
|
|
|
2557 (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
|
|
|
2558 (error "Message is already MIME encoded."))
|
|
|
2559 (let ((8bit nil)
|
|
|
2560 (just-one nil)
|
|
|
2561 (boundary-positions nil)
|
|
140
|
2562 (enriched (and (boundp 'enriched-mode) enriched-mode))
|
|
20
|
2563 already-mimed layout e e-list boundary
|
|
24
|
2564 type encoding charset params description disposition object
|
|
|
2565 opoint-min)
|
|
20
|
2566 (mail-text)
|
|
118
|
2567 (setq e-list (extent-list nil (point) (point-max))
|
|
20
|
2568 e-list (vm-delete (function
|
|
|
2569 (lambda (e)
|
|
118
|
2570 (extent-property e 'vm-mime-object)))
|
|
20
|
2571 e-list t)
|
|
|
2572 e-list (sort e-list (function
|
|
|
2573 (lambda (e1 e2)
|
|
118
|
2574 (< (extent-end-position e1)
|
|
|
2575 (extent-end-position e2))))))
|
|
20
|
2576 ;; If there's just one attachment and no other readable
|
|
|
2577 ;; text in the buffer then make the message type just be
|
|
|
2578 ;; the attachment type rather than sending a multipart
|
|
|
2579 ;; message with one attachment
|
|
|
2580 (setq just-one (and (= (length e-list) 1)
|
|
|
2581 (looking-at "[ \t\n]*")
|
|
|
2582 (= (match-end 0)
|
|
118
|
2583 (extent-start-position (car e-list)))
|
|
20
|
2584 (save-excursion
|
|
118
|
2585 (goto-char (extent-end-position (car e-list)))
|
|
20
|
2586 (looking-at "[ \t\n]*\\'"))))
|
|
|
2587 (if (null e-list)
|
|
|
2588 (progn
|
|
|
2589 (narrow-to-region (point) (point-max))
|
|
140
|
2590 ;; support enriched-mode for text/enriched composition
|
|
|
2591 (if enriched
|
|
|
2592 (let ((enriched-initial-annotation ""))
|
|
|
2593 (enriched-encode (point-min) (point-max))))
|
|
20
|
2594 (setq charset (vm-determine-proper-charset (point-min)
|
|
|
2595 (point-max)))
|
|
140
|
2596 (if vm-xemacs-mule-p
|
|
|
2597 (encode-coding-region (point-min) (point-max)
|
|
|
2598 buffer-file-coding-system))
|
|
20
|
2599 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
2600 (point-min)
|
|
|
2601 (point-max))
|
|
|
2602 encoding (vm-mime-transfer-encode-region encoding
|
|
|
2603 (point-min)
|
|
|
2604 (point-max)
|
|
|
2605 t))
|
|
|
2606 (widen)
|
|
|
2607 (vm-remove-mail-mode-header-separator)
|
|
|
2608 (goto-char (point-min))
|
|
|
2609 (vm-reorder-message-headers
|
|
|
2610 nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
|
|
|
2611 (insert "MIME-Version: 1.0\n")
|
|
140
|
2612 (if enriched
|
|
|
2613 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
2614 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
20
|
2615 (insert "Content-Transfer-Encoding: " encoding "\n")
|
|
|
2616 (vm-add-mail-mode-header-separator))
|
|
|
2617 (while e-list
|
|
|
2618 (setq e (car e-list))
|
|
118
|
2619 (if (or just-one (= (point) (extent-start-position e)))
|
|
20
|
2620 nil
|
|
118
|
2621 (narrow-to-region (point) (extent-start-position e))
|
|
140
|
2622 (if enriched
|
|
|
2623 (let ((enriched-initial-annotation ""))
|
|
|
2624 (enriched-encode (point-min) (point-max))))
|
|
20
|
2625 (setq charset (vm-determine-proper-charset (point-min)
|
|
|
2626 (point-max)))
|
|
140
|
2627 (if vm-xemacs-mule-p
|
|
|
2628 (encode-coding-region (point-min) (point-max)
|
|
|
2629 buffer-file-coding-system))
|
|
20
|
2630 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
2631 (point-min)
|
|
|
2632 (point-max))
|
|
|
2633 encoding (vm-mime-transfer-encode-region encoding
|
|
|
2634 (point-min)
|
|
|
2635 (point-max)
|
|
|
2636 t))
|
|
|
2637 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
140
|
2638 (if enriched
|
|
|
2639 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
2640 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
20
|
2641 (insert "Content-Transfer-Encoding: " encoding "\n\n")
|
|
|
2642 (widen))
|
|
118
|
2643 (goto-char (extent-start-position e))
|
|
20
|
2644 (narrow-to-region (point) (point))
|
|
118
|
2645 (setq object (extent-property e 'vm-mime-object))
|
|
24
|
2646 ;; insert the object
|
|
20
|
2647 (cond ((bufferp object)
|
|
118
|
2648 (insert-buffer-substring object))
|
|
20
|
2649 ((stringp object)
|
|
140
|
2650 (let ((coding-system-for-read 'no-conversion)
|
|
|
2651 ;; don't let buffer-file-coding-system be changed
|
|
131
|
2652 ;; by insert-file-contents-literally. The
|
|
|
2653 ;; value we bind to it to here isn't important.
|
|
140
|
2654 (buffer-file-coding-system 'no-conversion))
|
|
118
|
2655 (insert-file-contents-literally object))))
|
|
24
|
2656 ;; gather information about the object from the extent.
|
|
118
|
2657 (if (setq already-mimed (extent-property e 'vm-mime-encoded))
|
|
20
|
2658 (setq layout (vm-mime-parse-entity
|
|
|
2659 nil (list "text/plain" "charset=us-ascii")
|
|
|
2660 "7bit")
|
|
118
|
2661 type (or (extent-property e 'vm-mime-type)
|
|
24
|
2662 (car (vm-mm-layout-type layout)))
|
|
118
|
2663 params (or (extent-property e 'vm-mime-parameters)
|
|
24
|
2664 (cdr (vm-mm-layout-qtype layout)))
|
|
118
|
2665 description (extent-property e 'vm-mime-description)
|
|
30
|
2666 disposition
|
|
|
2667 (if (not
|
|
|
2668 (equal
|
|
118
|
2669 (car (extent-property e 'vm-mime-disposition))
|
|
30
|
2670 "unspecified"))
|
|
118
|
2671 (extent-property e 'vm-mime-disposition)
|
|
30
|
2672 (vm-mm-layout-qdisposition layout)))
|
|
118
|
2673 (setq type (extent-property e 'vm-mime-type)
|
|
|
2674 params (extent-property e 'vm-mime-parameters)
|
|
|
2675 description (extent-property e 'vm-mime-description)
|
|
30
|
2676 disposition
|
|
|
2677 (if (not (equal
|
|
118
|
2678 (car (extent-property e 'vm-mime-disposition))
|
|
30
|
2679 "unspecified"))
|
|
118
|
2680 (extent-property e 'vm-mime-disposition)
|
|
30
|
2681 nil)))
|
|
20
|
2682 (cond ((vm-mime-types-match "text" type)
|
|
|
2683 (setq encoding
|
|
|
2684 (vm-determine-proper-content-transfer-encoding
|
|
|
2685 (if already-mimed
|
|
|
2686 (vm-mm-layout-body-start layout)
|
|
|
2687 (point-min))
|
|
|
2688 (point-max))
|
|
|
2689 encoding (vm-mime-transfer-encode-region
|
|
|
2690 encoding
|
|
|
2691 (if already-mimed
|
|
|
2692 (vm-mm-layout-body-start layout)
|
|
|
2693 (point-min))
|
|
|
2694 (point-max)
|
|
|
2695 t))
|
|
|
2696 (setq 8bit (or 8bit (equal encoding "8bit"))))
|
|
136
|
2697 ((vm-mime-composite-type-p type)
|
|
20
|
2698 (setq opoint-min (point-min))
|
|
|
2699 (if (not already-mimed)
|
|
|
2700 (setq layout (vm-mime-parse-entity
|
|
|
2701 nil (list "text/plain" "charset=us-ascii")
|
|
|
2702 "7bit")))
|
|
136
|
2703 (setq encoding (vm-mime-transfer-encode-layout layout))
|
|
20
|
2704 (setq 8bit (or 8bit (equal encoding "8bit")))
|
|
|
2705 (goto-char (point-max))
|
|
|
2706 (widen)
|
|
|
2707 (narrow-to-region opoint-min (point)))
|
|
|
2708 (t
|
|
|
2709 (vm-mime-base64-encode-region
|
|
|
2710 (if already-mimed
|
|
|
2711 (vm-mm-layout-body-start layout)
|
|
|
2712 (point-min))
|
|
|
2713 (point-max))
|
|
|
2714 (setq encoding "base64")))
|
|
|
2715 (if just-one
|
|
|
2716 nil
|
|
|
2717 (goto-char (point-min))
|
|
|
2718 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
|
2719 (if (not already-mimed)
|
|
|
2720 nil
|
|
|
2721 ;; trim headers
|
|
|
2722 (vm-reorder-message-headers
|
|
24
|
2723 nil (nconc (list "Content-Disposition:" "Content-ID:")
|
|
|
2724 (if description
|
|
|
2725 (list "Content-Description:")
|
|
|
2726 nil))
|
|
|
2727 nil)
|
|
20
|
2728 ;; remove header/text separator
|
|
|
2729 (goto-char (1- (vm-mm-layout-body-start layout)))
|
|
|
2730 (if (looking-at "\n")
|
|
|
2731 (delete-char 1)))
|
|
|
2732 (insert "Content-Type: " type)
|
|
|
2733 (if params
|
|
|
2734 (if vm-mime-avoid-folding-content-type
|
|
|
2735 (insert "; " (mapconcat 'identity params "; ") "\n")
|
|
|
2736 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
|
|
|
2737 (insert "\n"))
|
|
24
|
2738 (and description
|
|
|
2739 (insert "Content-Description: " description "\n"))
|
|
|
2740 (if disposition
|
|
|
2741 (progn
|
|
|
2742 (insert "Content-Disposition: " (car disposition))
|
|
|
2743 (if (cdr disposition)
|
|
|
2744 (insert ";\n\t" (mapconcat 'identity
|
|
|
2745 (cdr disposition)
|
|
|
2746 ";\n\t")))
|
|
|
2747 (insert "\n")))
|
|
20
|
2748 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
|
|
|
2749 (goto-char (point-max))
|
|
|
2750 (widen)
|
|
30
|
2751 (save-excursion
|
|
118
|
2752 (goto-char (extent-start-position e))
|
|
30
|
2753 (vm-assert (looking-at "\\[ATTACHMENT")))
|
|
118
|
2754 (delete-region (extent-start-position e)
|
|
|
2755 (extent-end-position e))
|
|
|
2756 (detach-extent e)
|
|
24
|
2757 (if (looking-at "\n")
|
|
|
2758 (delete-char 1))
|
|
20
|
2759 (setq e-list (cdr e-list)))
|
|
|
2760 ;; handle the remaining chunk of text after the last
|
|
|
2761 ;; extent, if any.
|
|
|
2762 (if (or just-one (= (point) (point-max)))
|
|
|
2763 nil
|
|
140
|
2764 (if enriched
|
|
|
2765 (let ((enriched-initial-annotation ""))
|
|
|
2766 (enriched-encode (point) (point-max))))
|
|
20
|
2767 (setq charset (vm-determine-proper-charset (point)
|
|
|
2768 (point-max)))
|
|
140
|
2769 (if vm-xemacs-mule-p
|
|
|
2770 (encode-coding-region (point) (point-max)
|
|
|
2771 buffer-file-coding-system))
|
|
20
|
2772 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
2773 (point)
|
|
|
2774 (point-max))
|
|
|
2775 encoding (vm-mime-transfer-encode-region encoding
|
|
|
2776 (point)
|
|
|
2777 (point-max)
|
|
|
2778 t))
|
|
|
2779 (setq 8bit (or 8bit (equal encoding "8bit")))
|
|
|
2780 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
140
|
2781 (if enriched
|
|
|
2782 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
2783 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
20
|
2784 (insert "Content-Transfer-Encoding: " encoding "\n\n")
|
|
|
2785 (goto-char (point-max)))
|
|
|
2786 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
2787 (mail-text)
|
|
|
2788 (while (re-search-forward (concat "^--"
|
|
|
2789 (regexp-quote boundary)
|
|
|
2790 "\\(--\\)?$")
|
|
|
2791 nil t)
|
|
|
2792 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
2793 (mail-text))
|
|
|
2794 (goto-char (point-max))
|
|
|
2795 (or just-one (insert "\n--" boundary "--\n"))
|
|
|
2796 (while boundary-positions
|
|
|
2797 (goto-char (car boundary-positions))
|
|
|
2798 (insert "\n--" boundary "\n")
|
|
|
2799 (setq boundary-positions (cdr boundary-positions)))
|
|
|
2800 (if (and just-one already-mimed)
|
|
|
2801 (progn
|
|
|
2802 (goto-char (vm-mm-layout-header-start layout))
|
|
|
2803 ;; trim headers
|
|
|
2804 (vm-reorder-message-headers
|
|
|
2805 nil '("Content-Description:" "Content-ID:") nil)
|
|
|
2806 ;; remove header/text separator
|
|
|
2807 (goto-char (1- (vm-mm-layout-body-start layout)))
|
|
|
2808 (if (looking-at "\n")
|
|
|
2809 (delete-char 1))
|
|
|
2810 ;; copy remainder to enclosing entity's header section
|
|
|
2811 (insert-buffer-substring (current-buffer)
|
|
|
2812 (vm-mm-layout-header-start layout)
|
|
|
2813 (vm-mm-layout-body-start layout))
|
|
|
2814 (delete-region (vm-mm-layout-header-start layout)
|
|
|
2815 (vm-mm-layout-body-start layout))))
|
|
|
2816 (goto-char (point-min))
|
|
|
2817 (vm-remove-mail-mode-header-separator)
|
|
|
2818 (vm-reorder-message-headers
|
|
|
2819 nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
|
|
|
2820 (vm-add-mail-mode-header-separator)
|
|
|
2821 (insert "MIME-Version: 1.0\n")
|
|
|
2822 (if (not just-one)
|
|
|
2823 (insert (if vm-mime-avoid-folding-content-type
|
|
|
2824 "Content-Type: multipart/mixed; boundary=\""
|
|
|
2825 "Content-Type: multipart/mixed;\n\tboundary=\"")
|
|
|
2826 boundary "\"\n")
|
|
|
2827 (insert "Content-Type: " type)
|
|
|
2828 (if params
|
|
|
2829 (if vm-mime-avoid-folding-content-type
|
|
|
2830 (insert "; " (mapconcat 'identity params "; ") "\n")
|
|
126
|
2831 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
|
|
|
2832 (insert "\n")))
|
|
20
|
2833 (if just-one
|
|
24
|
2834 (and description
|
|
|
2835 (insert "Content-Description: " description "\n")))
|
|
|
2836 (if (and just-one disposition)
|
|
|
2837 (progn
|
|
|
2838 (insert "Content-Disposition: " (car disposition))
|
|
|
2839 (if (cdr disposition)
|
|
126
|
2840 (if vm-mime-avoid-folding-content-type
|
|
|
2841 (insert "; " (mapconcat 'identity (cdr disposition) "; ")
|
|
|
2842 "\n")
|
|
|
2843 (insert ";\n\t" (mapconcat 'identity (cdr disposition)
|
|
|
2844 ";\n\t")))
|
|
|
2845 (insert "\n"))))
|
|
24
|
2846 (if just-one
|
|
20
|
2847 (insert "Content-Transfer-Encoding: " encoding "\n")
|
|
|
2848 (if 8bit
|
|
|
2849 (insert "Content-Transfer-Encoding: 8bit\n")
|
|
|
2850 (insert "Content-Transfer-Encoding: 7bit\n")))))))
|
|
|
2851
|
|
118
|
2852 (defun vm-mime-fsfemacs-encode-composition ()
|
|
|
2853 (save-restriction
|
|
|
2854 (widen)
|
|
|
2855 (if (not (eq major-mode 'mail-mode))
|
|
|
2856 (error "Command must be used in a VM Mail mode buffer."))
|
|
|
2857 (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
|
|
|
2858 (error "Message is already MIME encoded."))
|
|
|
2859 (let ((8bit nil)
|
|
|
2860 (just-one nil)
|
|
|
2861 (boundary-positions nil)
|
|
140
|
2862 (enriched (and (boundp 'enriched-mode) enriched-mode))
|
|
118
|
2863 already-mimed layout o o-list boundary
|
|
|
2864 type encoding charset params description disposition object
|
|
|
2865 opoint-min)
|
|
|
2866 (mail-text)
|
|
|
2867 (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max))
|
|
|
2868 o-list (vm-delete (function
|
|
|
2869 (lambda (o)
|
|
|
2870 (overlay-get o 'vm-mime-object)))
|
|
|
2871 o-list t)
|
|
|
2872 o-list (sort o-list (function
|
|
|
2873 (lambda (e1 e2)
|
|
|
2874 (< (overlay-end e1)
|
|
|
2875 (overlay-end e2))))))
|
|
|
2876 ;; If there's just one attachment and no other readable
|
|
|
2877 ;; text in the buffer then make the message type just be
|
|
|
2878 ;; the attachment type rather than sending a multipart
|
|
|
2879 ;; message with one attachment
|
|
|
2880 (setq just-one (and (= (length o-list) 1)
|
|
|
2881 (looking-at "[ \t\n]*")
|
|
|
2882 (= (match-end 0)
|
|
|
2883 (overlay-start (car o-list)))
|
|
|
2884 (save-excursion
|
|
|
2885 (goto-char (overlay-end (car o-list)))
|
|
|
2886 (looking-at "[ \t\n]*\\'"))))
|
|
|
2887 (if (null o-list)
|
|
|
2888 (progn
|
|
|
2889 (narrow-to-region (point) (point-max))
|
|
140
|
2890 ;; support enriched-mode for text/enriched composition
|
|
|
2891 (if enriched
|
|
|
2892 (let ((enriched-initial-annotation ""))
|
|
|
2893 (enriched-encode (point-min) (point-max))))
|
|
118
|
2894 (setq charset (vm-determine-proper-charset (point-min)
|
|
|
2895 (point-max)))
|
|
|
2896 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
2897 (point-min)
|
|
|
2898 (point-max))
|
|
|
2899 encoding (vm-mime-transfer-encode-region encoding
|
|
|
2900 (point-min)
|
|
|
2901 (point-max)
|
|
|
2902 t))
|
|
|
2903 (widen)
|
|
|
2904 (vm-remove-mail-mode-header-separator)
|
|
|
2905 (goto-char (point-min))
|
|
|
2906 (vm-reorder-message-headers
|
|
|
2907 nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
|
|
|
2908 (insert "MIME-Version: 1.0\n")
|
|
140
|
2909 (if enriched
|
|
|
2910 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
2911 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
118
|
2912 (insert "Content-Transfer-Encoding: " encoding "\n")
|
|
|
2913 (vm-add-mail-mode-header-separator))
|
|
|
2914 (while o-list
|
|
|
2915 (setq o (car o-list))
|
|
|
2916 (if (or just-one (= (point) (overlay-start o)))
|
|
|
2917 nil
|
|
|
2918 (narrow-to-region (point) (overlay-start o))
|
|
140
|
2919 ;; support enriched-mode for text/enriched composition
|
|
|
2920 (if enriched
|
|
|
2921 (let ((enriched-initial-annotation ""))
|
|
|
2922 (save-excursion
|
|
|
2923 ;; insert/delete trick needed to avoid
|
|
|
2924 ;; enriched-mode tags from seeping into the
|
|
|
2925 ;; attachment overlays. I really wish
|
|
146
|
2926 ;; front-advance / rear-advance overlay
|
|
140
|
2927 ;; endpoint properties actually worked.
|
|
|
2928 (goto-char (point-max))
|
|
|
2929 (insert-before-markers "\n")
|
|
|
2930 (enriched-encode (point-min) (1- (point)))
|
|
|
2931 (goto-char (point-max))
|
|
|
2932 (delete-char -1)
|
|
|
2933 '(goto-char (point-min)))))
|
|
118
|
2934 (setq charset (vm-determine-proper-charset (point-min)
|
|
|
2935 (point-max)))
|
|
|
2936 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
2937 (point-min)
|
|
|
2938 (point-max))
|
|
|
2939 encoding (vm-mime-transfer-encode-region encoding
|
|
|
2940 (point-min)
|
|
|
2941 (point-max)
|
|
|
2942 t))
|
|
|
2943 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
140
|
2944 (if enriched
|
|
|
2945 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
2946 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
118
|
2947 (insert "Content-Transfer-Encoding: " encoding "\n\n")
|
|
|
2948 (widen))
|
|
|
2949 (goto-char (overlay-start o))
|
|
|
2950 (narrow-to-region (point) (point))
|
|
|
2951 (setq object (overlay-get o 'vm-mime-object))
|
|
|
2952 ;; insert the object
|
|
|
2953 (cond ((bufferp object)
|
|
|
2954 ;; as of FSF Emacs 19.34, even with the hooks
|
|
|
2955 ;; we've attached to the attachment overlays,
|
|
|
2956 ;; text STILL can be inserted into them when
|
|
|
2957 ;; font-lock is enabled. Explaining why is
|
|
|
2958 ;; beyond the scope of this comment and I
|
|
|
2959 ;; don't know the answer anyway. This works
|
|
|
2960 ;; to prevent it.
|
|
|
2961 (insert-before-markers " ")
|
|
|
2962 (forward-char -1)
|
|
|
2963 (insert-buffer-substring object)
|
|
|
2964 (delete-char 1))
|
|
|
2965 ((stringp object)
|
|
|
2966 (insert-before-markers " ")
|
|
|
2967 (forward-char -1)
|
|
|
2968 (insert-file-contents object)
|
|
|
2969 (goto-char (point-max))
|
|
|
2970 (delete-char -1)))
|
|
|
2971 ;; gather information about the object from the extent.
|
|
|
2972 (if (setq already-mimed (overlay-get o 'vm-mime-encoded))
|
|
|
2973 (setq layout (vm-mime-parse-entity
|
|
|
2974 nil (list "text/plain" "charset=us-ascii")
|
|
|
2975 "7bit")
|
|
|
2976 type (or (overlay-get o 'vm-mime-type)
|
|
|
2977 (car (vm-mm-layout-type layout)))
|
|
|
2978 params (or (overlay-get o 'vm-mime-parameters)
|
|
|
2979 (cdr (vm-mm-layout-qtype layout)))
|
|
|
2980 description (overlay-get o 'vm-mime-description)
|
|
|
2981 disposition
|
|
|
2982 (if (not
|
|
|
2983 (equal
|
|
|
2984 (car (overlay-get o 'vm-mime-disposition))
|
|
|
2985 "unspecified"))
|
|
|
2986 (overlay-get o 'vm-mime-disposition)
|
|
|
2987 (vm-mm-layout-qdisposition layout)))
|
|
|
2988 (setq type (overlay-get o 'vm-mime-type)
|
|
|
2989 params (overlay-get o 'vm-mime-parameters)
|
|
|
2990 description (overlay-get o 'vm-mime-description)
|
|
|
2991 disposition
|
|
|
2992 (if (not (equal
|
|
|
2993 (car (overlay-get o 'vm-mime-disposition))
|
|
|
2994 "unspecified"))
|
|
|
2995 (overlay-get o 'vm-mime-disposition)
|
|
|
2996 nil)))
|
|
|
2997 (cond ((vm-mime-types-match "text" type)
|
|
|
2998 (setq encoding
|
|
|
2999 (vm-determine-proper-content-transfer-encoding
|
|
|
3000 (if already-mimed
|
|
|
3001 (vm-mm-layout-body-start layout)
|
|
|
3002 (point-min))
|
|
|
3003 (point-max))
|
|
|
3004 encoding (vm-mime-transfer-encode-region
|
|
|
3005 encoding
|
|
|
3006 (if already-mimed
|
|
|
3007 (vm-mm-layout-body-start layout)
|
|
|
3008 (point-min))
|
|
|
3009 (point-max)
|
|
|
3010 t))
|
|
|
3011 (setq 8bit (or 8bit (equal encoding "8bit"))))
|
|
136
|
3012 ((vm-mime-composite-type-p type)
|
|
118
|
3013 (setq opoint-min (point-min))
|
|
|
3014 (if (not already-mimed)
|
|
|
3015 (setq layout (vm-mime-parse-entity
|
|
|
3016 nil (list "text/plain" "charset=us-ascii")
|
|
|
3017 "7bit")))
|
|
136
|
3018 (setq encoding (vm-mime-transfer-encode-layout layout))
|
|
118
|
3019 (setq 8bit (or 8bit (equal encoding "8bit")))
|
|
|
3020 (goto-char (point-max))
|
|
|
3021 (widen)
|
|
|
3022 (narrow-to-region opoint-min (point)))
|
|
|
3023 (t
|
|
|
3024 (vm-mime-base64-encode-region
|
|
|
3025 (if already-mimed
|
|
|
3026 (vm-mm-layout-body-start layout)
|
|
|
3027 (point-min))
|
|
|
3028 (point-max))
|
|
|
3029 (setq encoding "base64")))
|
|
|
3030 (if just-one
|
|
|
3031 nil
|
|
|
3032 (goto-char (point-min))
|
|
|
3033 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
|
3034 (if (not already-mimed)
|
|
|
3035 nil
|
|
|
3036 ;; trim headers
|
|
|
3037 (vm-reorder-message-headers
|
|
|
3038 nil (nconc (list "Content-Disposition:" "Content-ID:")
|
|
|
3039 (if description
|
|
|
3040 (list "Content-Description:")
|
|
|
3041 nil))
|
|
|
3042 nil)
|
|
|
3043 ;; remove header/text separator
|
|
|
3044 (goto-char (1- (vm-mm-layout-body-start layout)))
|
|
|
3045 (if (looking-at "\n")
|
|
|
3046 (delete-char 1)))
|
|
|
3047 (insert "Content-Type: " type)
|
|
|
3048 (if params
|
|
|
3049 (if vm-mime-avoid-folding-content-type
|
|
|
3050 (insert "; " (mapconcat 'identity params "; ") "\n")
|
|
|
3051 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
|
|
|
3052 (insert "\n"))
|
|
|
3053 (and description
|
|
|
3054 (insert "Content-Description: " description "\n"))
|
|
|
3055 (if disposition
|
|
|
3056 (progn
|
|
|
3057 (insert "Content-Disposition: " (car disposition))
|
|
|
3058 (if (cdr disposition)
|
|
|
3059 (insert ";\n\t" (mapconcat 'identity
|
|
|
3060 (cdr disposition)
|
|
|
3061 ";\n\t")))
|
|
|
3062 (insert "\n")))
|
|
|
3063 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
|
|
|
3064 (goto-char (point-max))
|
|
|
3065 (widen)
|
|
|
3066 (save-excursion
|
|
|
3067 (goto-char (overlay-start o))
|
|
|
3068 (vm-assert (looking-at "\\[ATTACHMENT")))
|
|
|
3069 (delete-region (overlay-start o)
|
|
|
3070 (overlay-end o))
|
|
|
3071 (delete-overlay o)
|
|
|
3072 (if (looking-at "\n")
|
|
|
3073 (delete-char 1))
|
|
|
3074 (setq o-list (cdr o-list)))
|
|
|
3075 ;; handle the remaining chunk of text after the last
|
|
|
3076 ;; extent, if any.
|
|
|
3077 (if (or just-one (= (point) (point-max)))
|
|
|
3078 nil
|
|
140
|
3079 ;; support enriched-mode for text/enriched composition
|
|
|
3080 (if enriched
|
|
|
3081 (let ((enriched-initial-annotation ""))
|
|
|
3082 (enriched-encode (point) (point-max))))
|
|
118
|
3083 (setq charset (vm-determine-proper-charset (point)
|
|
|
3084 (point-max)))
|
|
|
3085 (setq encoding (vm-determine-proper-content-transfer-encoding
|
|
|
3086 (point)
|
|
|
3087 (point-max))
|
|
|
3088 encoding (vm-mime-transfer-encode-region encoding
|
|
|
3089 (point)
|
|
|
3090 (point-max)
|
|
|
3091 t))
|
|
|
3092 (setq 8bit (or 8bit (equal encoding "8bit")))
|
|
|
3093 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
140
|
3094 (if enriched
|
|
|
3095 (insert "Content-Type: text/enriched; charset=" charset "\n")
|
|
|
3096 (insert "Content-Type: text/plain; charset=" charset "\n"))
|
|
118
|
3097 (insert "Content-Transfer-Encoding: " encoding "\n\n")
|
|
|
3098 (goto-char (point-max)))
|
|
|
3099 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
3100 (mail-text)
|
|
|
3101 (while (re-search-forward (concat "^--"
|
|
|
3102 (regexp-quote boundary)
|
|
|
3103 "\\(--\\)?$")
|
|
|
3104 nil t)
|
|
|
3105 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
3106 (mail-text))
|
|
|
3107 (goto-char (point-max))
|
|
|
3108 (or just-one (insert "\n--" boundary "--\n"))
|
|
|
3109 (while boundary-positions
|
|
|
3110 (goto-char (car boundary-positions))
|
|
|
3111 (insert "\n--" boundary "\n")
|
|
|
3112 (setq boundary-positions (cdr boundary-positions)))
|
|
|
3113 (if (and just-one already-mimed)
|
|
|
3114 (progn
|
|
|
3115 (goto-char (vm-mm-layout-header-start layout))
|
|
|
3116 ;; trim headers
|
|
|
3117 (vm-reorder-message-headers
|
|
|
3118 nil '("Content-Description:" "Content-ID:") nil)
|
|
|
3119 ;; remove header/text separator
|
|
|
3120 (goto-char (1- (vm-mm-layout-body-start layout)))
|
|
|
3121 (if (looking-at "\n")
|
|
|
3122 (delete-char 1))
|
|
|
3123 ;; copy remainder to enclosing entity's header section
|
|
|
3124 (insert-buffer-substring (current-buffer)
|
|
|
3125 (vm-mm-layout-header-start layout)
|
|
|
3126 (vm-mm-layout-body-start layout))
|
|
|
3127 (delete-region (vm-mm-layout-header-start layout)
|
|
|
3128 (vm-mm-layout-body-start layout))))
|
|
|
3129 (goto-char (point-min))
|
|
|
3130 (vm-remove-mail-mode-header-separator)
|
|
|
3131 (vm-reorder-message-headers
|
|
|
3132 nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
|
|
|
3133 (vm-add-mail-mode-header-separator)
|
|
|
3134 (insert "MIME-Version: 1.0\n")
|
|
|
3135 (if (not just-one)
|
|
|
3136 (insert (if vm-mime-avoid-folding-content-type
|
|
|
3137 "Content-Type: multipart/mixed; boundary=\""
|
|
|
3138 "Content-Type: multipart/mixed;\n\tboundary=\"")
|
|
|
3139 boundary "\"\n")
|
|
|
3140 (insert "Content-Type: " type)
|
|
|
3141 (if params
|
|
|
3142 (if vm-mime-avoid-folding-content-type
|
|
|
3143 (insert "; " (mapconcat 'identity params "; ") "\n")
|
|
126
|
3144 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
|
|
|
3145 (insert "\n")))
|
|
118
|
3146 (if just-one
|
|
|
3147 (and description
|
|
|
3148 (insert "Content-Description: " description "\n")))
|
|
|
3149 (if (and just-one disposition)
|
|
|
3150 (progn
|
|
|
3151 (insert "Content-Disposition: " (car disposition))
|
|
|
3152 (if (cdr disposition)
|
|
126
|
3153 (if vm-mime-avoid-folding-content-type
|
|
|
3154 (insert "; " (mapconcat 'identity (cdr disposition) "; ")
|
|
|
3155 "\n")
|
|
|
3156 (insert ";\n\t" (mapconcat 'identity (cdr disposition)
|
|
|
3157 ";\n\t")))
|
|
|
3158 (insert "\n"))))
|
|
118
|
3159 (if just-one
|
|
|
3160 (insert "Content-Transfer-Encoding: " encoding "\n")
|
|
|
3161 (if 8bit
|
|
|
3162 (insert "Content-Transfer-Encoding: 8bit\n")
|
|
|
3163 (insert "Content-Transfer-Encoding: 7bit\n")))))))
|
|
|
3164
|
|
20
|
3165 (defun vm-mime-fragment-composition (size)
|
|
|
3166 (save-restriction
|
|
|
3167 (widen)
|
|
26
|
3168 (message "Fragmenting message...")
|
|
20
|
3169 (let ((buffers nil)
|
|
|
3170 (id (vm-mime-make-multipart-boundary))
|
|
|
3171 (n 1)
|
|
|
3172 (the-end nil)
|
|
|
3173 b header-start header-end master-buffer start end)
|
|
|
3174 (vm-remove-mail-mode-header-separator)
|
|
|
3175 ;; message/partial must have "7bit" content transfer
|
|
136
|
3176 ;; encoding, so force everything to be encoded for
|
|
20
|
3177 ;; 7bit transmission.
|
|
|
3178 (let ((vm-mime-8bit-text-transfer-encoding
|
|
118
|
3179 (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
|
|
20
|
3180 'quoted-printable
|
|
|
3181 vm-mime-8bit-text-transfer-encoding)))
|
|
136
|
3182 (vm-mime-transfer-encode-layout
|
|
|
3183 (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
|
|
|
3184 "7bit")))
|
|
20
|
3185 (goto-char (point-min))
|
|
|
3186 (setq header-start (point))
|
|
|
3187 (search-forward "\n\n")
|
|
|
3188 (setq header-end (1- (point)))
|
|
|
3189 (setq master-buffer (current-buffer))
|
|
|
3190 (goto-char (point-min))
|
|
|
3191 (setq start (point))
|
|
|
3192 (while (not (eobp))
|
|
|
3193 (condition-case nil
|
|
|
3194 (progn
|
|
|
3195 (forward-char (max (- size 150) 2000))
|
|
|
3196 (beginning-of-line))
|
|
|
3197 (end-of-buffer (setq the-end t)))
|
|
|
3198 (setq end (point))
|
|
|
3199 (setq b (generate-new-buffer (concat (buffer-name) " part "
|
|
|
3200 (int-to-string n))))
|
|
|
3201 (setq buffers (cons b buffers))
|
|
|
3202 (set-buffer b)
|
|
|
3203 (make-local-variable 'vm-send-using-mime)
|
|
|
3204 (setq vm-send-using-mime nil)
|
|
|
3205 (insert-buffer-substring master-buffer header-start header-end)
|
|
|
3206 (goto-char (point-min))
|
|
|
3207 (vm-reorder-message-headers nil nil
|
|
|
3208 "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
|
|
|
3209 (insert "MIME-Version: 1.0\n")
|
|
|
3210 (insert (format
|
|
|
3211 (if vm-mime-avoid-folding-content-type
|
|
|
3212 "Content-Type: message/partial; id=%s; number=%d"
|
|
|
3213 "Content-Type: message/partial;\n\tid=%s;\n\tnumber=%d")
|
|
|
3214 id n))
|
|
|
3215 (if the-end
|
|
|
3216 (if vm-mime-avoid-folding-content-type
|
|
|
3217 (insert (format "; total=%d\n" n))
|
|
|
3218 (insert (format ";\n\ttotal=%d\n" n)))
|
|
|
3219 (insert "\n"))
|
|
|
3220 (insert "Content-Transfer-Encoding: 7bit\n")
|
|
|
3221 (goto-char (point-max))
|
|
|
3222 (insert mail-header-separator "\n")
|
|
|
3223 (insert-buffer-substring master-buffer start end)
|
|
|
3224 (vm-increment n)
|
|
|
3225 (set-buffer master-buffer)
|
|
|
3226 (setq start (point)))
|
|
118
|
3227 (vm-add-mail-mode-header-separator)
|
|
26
|
3228 (message "Fragmenting message... done")
|
|
20
|
3229 (nreverse buffers))))
|
|
|
3230
|
|
|
3231 (defun vm-mime-preview-composition ()
|
|
|
3232 "Show how the current composition buffer might be displayed
|
|
|
3233 in a MIME-aware mail reader. VM copies and encodes the current
|
|
|
3234 mail composition buffer and displays it as a mail folder.
|
|
|
3235 Type `q' to quit this temp folder and return to composing your
|
|
|
3236 message."
|
|
|
3237 (interactive)
|
|
|
3238 (if (not (eq major-mode 'mail-mode))
|
|
|
3239 (error "Command must be used in a VM Mail mode buffer."))
|
|
|
3240 (let ((temp-buffer nil)
|
|
|
3241 (mail-buffer (current-buffer))
|
|
146
|
3242 (enriched (and (boundp 'enriched-mode) enriched-mode))
|
|
20
|
3243 e-list)
|
|
|
3244 (unwind-protect
|
|
|
3245 (progn
|
|
|
3246 (setq temp-buffer (generate-new-buffer "composition preview"))
|
|
|
3247 (set-buffer temp-buffer)
|
|
126
|
3248 ;; so vm-mime-xxxx-encode-composition won't complain
|
|
20
|
3249 (setq major-mode 'mail-mode)
|
|
146
|
3250 (set (make-local-variable 'enriched-mode) enriched)
|
|
20
|
3251 (vm-insert-region-from-buffer mail-buffer)
|
|
|
3252 (goto-char (point-min))
|
|
|
3253 (or (vm-mail-mode-get-header-contents "From")
|
|
114
|
3254 (insert "From: " (user-login-name) "\n"))
|
|
20
|
3255 (or (vm-mail-mode-get-header-contents "Message-ID")
|
|
24
|
3256 (insert "Message-ID: <fake@fake.fake>\n"))
|
|
20
|
3257 (or (vm-mail-mode-get-header-contents "Date")
|
|
|
3258 (insert "Date: "
|
|
|
3259 (format-time-string "%a, %d %b %Y %H%M%S %Z"
|
|
|
3260 (current-time))
|
|
|
3261 "\n"))
|
|
|
3262 (and vm-send-using-mime
|
|
|
3263 (null (vm-mail-mode-get-header-contents "MIME-Version:"))
|
|
|
3264 (vm-mime-encode-composition))
|
|
126
|
3265 (vm-remove-mail-mode-header-separator)
|
|
20
|
3266 (goto-char (point-min))
|
|
|
3267 (insert (vm-leading-message-separator 'From_))
|
|
|
3268 (goto-char (point-max))
|
|
|
3269 (insert (vm-trailing-message-separator 'From_))
|
|
|
3270 (set-buffer-modified-p nil)
|
|
|
3271 ;; point of no return, don't kill it if the user quits
|
|
|
3272 (setq temp-buffer nil)
|
|
|
3273 (let ((vm-auto-decode-mime-messages t)
|
|
|
3274 (vm-auto-displayed-mime-content-types t))
|
|
|
3275 (vm-save-buffer-excursion
|
|
|
3276 (vm-goto-new-folder-frame-maybe 'folder)
|
|
|
3277 (vm-mode)))
|
|
|
3278 (message
|
|
|
3279 (substitute-command-keys
|
|
|
3280 "Type \\[vm-quit] to continue composing your message"))
|
|
|
3281 ;; temp buffer, don't offer to save it.
|
|
|
3282 (setq buffer-offer-save nil)
|
|
|
3283 (vm-display (or vm-presentation-buffer (current-buffer)) t
|
|
|
3284 (list this-command) '(vm-mode startup)))
|
|
|
3285 (and temp-buffer (kill-buffer temp-buffer)))))
|
|
|
3286
|
|
|
3287 (defun vm-mime-composite-type-p (type)
|
|
136
|
3288 (or (and (vm-mime-types-match "message" type)
|
|
|
3289 (not (vm-mime-types-match "message/partial" type))
|
|
|
3290 (not (vm-mime-types-match "message/external-body" type)))
|
|
20
|
3291 (vm-mime-types-match "multipart" type)))
|
|
|
3292
|
|
136
|
3293 ;; Unused currrently.
|
|
|
3294 ;;
|
|
|
3295 ;;(defun vm-mime-map-atomic-layouts (function list)
|
|
|
3296 ;; (while list
|
|
|
3297 ;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
|
|
|
3298 ;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
|
|
|
3299 ;; (funcall function (car list)))
|
|
|
3300 ;; (setq list (cdr list))))
|
