Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents 859a2309aef8
children 441bb1e64a06
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
25 (define-error 'vm-mime-error "MIME error") 25 (define-error 'vm-mime-error "MIME error")
26 (put 'vm-mime-error 'error-conditions '(vm-mime-error error)) 26 (put 'vm-mime-error 'error-conditions '(vm-mime-error error))
27 (put 'vm-mime-error 'error-message "MIME error")) 27 (put 'vm-mime-error 'error-message "MIME error"))
28 28
29 (defun vm-mm-layout-type (e) (aref e 0)) 29 (defun vm-mm-layout-type (e) (aref e 0))
30 (defun vm-mm-layout-encoding (e) (aref e 1)) 30 (defun vm-mm-layout-qtype (e) (aref e 1))
31 (defun vm-mm-layout-id (e) (aref e 2)) 31 (defun vm-mm-layout-encoding (e) (aref e 2))
32 (defun vm-mm-layout-description (e) (aref e 3)) 32 (defun vm-mm-layout-id (e) (aref e 3))
33 (defun vm-mm-layout-disposition (e) (aref e 4)) 33 (defun vm-mm-layout-description (e) (aref e 4))
34 (defun vm-mm-layout-header-start (e) (aref e 5)) 34 (defun vm-mm-layout-disposition (e) (aref e 5))
35 (defun vm-mm-layout-body-start (e) (aref e 6)) 35 (defun vm-mm-layout-qdisposition (e) (aref e 6))
36 (defun vm-mm-layout-body-end (e) (aref e 7)) 36 (defun vm-mm-layout-header-start (e) (aref e 7))
37 (defun vm-mm-layout-parts (e) (aref e 8)) 37 (defun vm-mm-layout-body-start (e) (aref e 8))
38 (defun vm-mm-layout-cache (e) (aref e 9)) 38 (defun vm-mm-layout-body-end (e) (aref e 9))
39 39 (defun vm-mm-layout-parts (e) (aref e 10))
40 (defun vm-set-mm-layout-cache (e c) (aset e 8 c)) 40 (defun vm-mm-layout-cache (e) (aref e 11))
41
42 (defun vm-set-mm-layout-cache (e c) (aset e 11 c))
41 43
42 (defun vm-mm-layout (m) 44 (defun vm-mm-layout (m)
43 (or (vm-mime-layout-of m) 45 (or (vm-mime-layout-of m)
44 (progn (vm-set-mime-layout-of 46 (progn (vm-set-mime-layout-of
45 m 47 m
72 (fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region) 74 (fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region)
73 75
74 (defun vm-mime-Q-encode-region (start end) 76 (defun vm-mime-Q-encode-region (start end)
75 (let ((buffer-read-only nil)) 77 (let ((buffer-read-only nil))
76 (subst-char-in-region start end (string-to-char " ") ?_ t) 78 (subst-char-in-region start end (string-to-char " ") ?_ t)
77 (vm-mime-qp-encode-region start end))) 79 (vm-mime-qp-encode-region start end t)))
78 80
79 (fset 'vm-mime-B-encode-region 'vm-mime-base64-encode-region) 81 (defun vm-mime-B-encode-region (start end)
80 82 (vm-mime-base64-encode-region start end nil t))
81 (defun vm-mime-Q-decode-string (string)
82 (vm-with-string-as-region string 'vm-mime-Q-decode-region))
83
84 (defun vm-mime-B-decode-string (string)
85 (vm-with-string-as-region string 'vm-mime-B-decode-region))
86
87 (defun vm-mime-Q-encode-string (string)
88 (vm-with-string-as-region string 'vm-mime-Q-encode-region))
89
90 (defun vm-mime-B-encode-string (string)
91 (vm-with-string-as-region string 'vm-mime-B-encode-region))
92 83
93 (defun vm-mime-crlf-to-lf-region (start end) 84 (defun vm-mime-crlf-to-lf-region (start end)
94 (let ((buffer-read-only nil)) 85 (let ((buffer-read-only nil))
95 (save-excursion 86 (save-excursion
96 (save-restriction 87 (save-restriction
109 (while (search-forward "\n" nil t) 100 (while (search-forward "\n" nil t)
110 (delete-char -1) 101 (delete-char -1)
111 (insert "\r\n")))))) 102 (insert "\r\n"))))))
112 103
113 (defun vm-mime-charset-decode-region (charset start end) 104 (defun vm-mime-charset-decode-region (charset start end)
114 (let ((buffer-read-only nil) 105 (or (markerp end) (setq end (vm-marker end)))
115 (cell (vm-mime-charset-internally-displayable-p charset)) 106 (cond ((vm-xemacs-mule-p)
116 (opoint (point))) 107 (if (eq (device-type) 'x)
117 (cond ((and cell (vm-xemacs-mule-p) (eq (device-type) 'x)) 108 (let ((buffer-read-only nil)
118 (decode-coding-region start end (car cell)))) 109 (cell (cdr (vm-string-assoc
119 ;; In XEmacs 20.0 beta93 decode-coding-region moves point. 110 charset
120 (goto-char opoint))) 111 vm-mime-mule-charset-to-coding-alist)))
112 (oend (marker-position end))
113 (opoint (point)))
114 (if cell
115 (progn
116 (set-marker end (+ start
117 (or (decode-coding-region
118 start end (car cell))
119 (- oend start))))
120 (put-text-property start end 'vm-string t)
121 (put-text-property start end 'vm-charset charset)
122 (put-text-property start end 'vm-coding (car cell))))
123 ;; In XEmacs 20.0 beta93 decode-coding-region moves point.
124 (goto-char opoint))))
125 ((not (vm-multiple-fonts-possible-p)) nil)
126 ((vm-string-member charset vm-mime-default-face-charsets) nil)
127 (t
128 (let ((font (cdr (vm-string-assoc
129 charset
130 vm-mime-charset-font-alist)))
131 (face (make-face (make-symbol "temp-face")))
132 (e (vm-make-extent start end)))
133 (put-text-property start end 'vm-string t)
134 (put-text-property start end 'vm-charset charset)
135 (if font
136 (condition-case data
137 (progn (set-face-font face font)
138 (vm-set-extent-property e 'face face))
139 (error nil)))))))
121 140
122 (defun vm-mime-transfer-decode-region (layout start end) 141 (defun vm-mime-transfer-decode-region (layout start end)
123 (let ((case-fold-search t) (crlf nil)) 142 (let ((case-fold-search t) (crlf nil))
124 (cond ((string-match "^base64$" (vm-mm-layout-encoding layout)) 143 (cond ((string-match "^base64$" (vm-mm-layout-encoding layout))
125 (cond ((vm-mime-types-match "text" 144 (cond ((vm-mime-types-match "text"
200 (insert-buffer-substring work-buffer) 219 (insert-buffer-substring work-buffer)
201 (delete-region (point) end)) 220 (delete-region (point) end))
202 (and work-buffer (kill-buffer work-buffer)))) 221 (and work-buffer (kill-buffer work-buffer))))
203 (vm-unsaved-message "Decoding base64... done")) 222 (vm-unsaved-message "Decoding base64... done"))
204 223
205 (defun vm-mime-base64-encode-region (start end &optional crlf) 224 (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding)
206 (vm-unsaved-message "Encoding base64...") 225 (and (> (- end start) 200)
226 (vm-unsaved-message "Encoding base64..."))
207 (let ((work-buffer nil) 227 (let ((work-buffer nil)
208 (counter 0) 228 (counter 0)
209 (cols 0) 229 (cols 0)
210 (bits 0) 230 (bits 0)
211 (alphabet vm-mime-base64-alphabet) 231 (alphabet vm-mime-base64-alphabet)
238 1 nil work-buffer) 258 1 nil work-buffer)
239 (vm-insert-char (aref alphabet (logand bits 63)) 1 nil 259 (vm-insert-char (aref alphabet (logand bits 63)) 1 nil
240 work-buffer) 260 work-buffer)
241 (setq cols (+ cols 4)) 261 (setq cols (+ cols 4))
242 (cond ((= cols 72) 262 (cond ((= cols 72)
243 (vm-insert-char ?\n 1 nil work-buffer) 263 (setq cols 0)
244 (setq cols 0))) 264 (if (not B-encoding)
265 (vm-insert-char ?\n 1 nil work-buffer))))
245 (setq bits 0 counter 0)) 266 (setq bits 0 counter 0))
246 (t (setq bits (lsh bits 8)))) 267 (t (setq bits (lsh bits 8))))
247 (vm-increment inputpos)) 268 (vm-increment inputpos))
248 ;; write out any remaining bits with appropriate padding 269 ;; write out any remaining bits with appropriate padding
249 (if (= counter 0) 270 (if (= counter 0)
261 (if (> cols 0) 282 (if (> cols 0)
262 (vm-insert-char ?\n 1 nil work-buffer))) 283 (vm-insert-char ?\n 1 nil work-buffer)))
263 (or (markerp end) (setq end (vm-marker end))) 284 (or (markerp end) (setq end (vm-marker end)))
264 (goto-char start) 285 (goto-char start)
265 (insert-buffer-substring work-buffer) 286 (insert-buffer-substring work-buffer)
266 (delete-region (point) end)) 287 (delete-region (point) end)
267 (and work-buffer (kill-buffer work-buffer)))) 288 (and (> (- end start) 200)
268 (vm-unsaved-message "Encoding base64... done")) 289 (vm-unsaved-message "Encoding base64... done"))
290 (- end start))
291 (and work-buffer (kill-buffer work-buffer)))))
269 292
270 (defun vm-mime-qp-decode-region (start end) 293 (defun vm-mime-qp-decode-region (start end)
271 (vm-unsaved-message "Decoding quoted-printable...") 294 (and (> (- end start) 200)
295 (vm-unsaved-message "Decoding quoted-printable..."))
272 (let ((work-buffer nil) 296 (let ((work-buffer nil)
273 (buf (current-buffer)) 297 (buf (current-buffer))
274 (case-fold-search nil) 298 (case-fold-search nil)
275 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) 299 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
276 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) 300 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
327 (or (markerp end) (setq end (vm-marker end))) 351 (or (markerp end) (setq end (vm-marker end)))
328 (goto-char start) 352 (goto-char start)
329 (insert-buffer-substring work-buffer) 353 (insert-buffer-substring work-buffer)
330 (delete-region (point) end)) 354 (delete-region (point) end))
331 (and work-buffer (kill-buffer work-buffer)))) 355 (and work-buffer (kill-buffer work-buffer))))
332 (vm-unsaved-message "Decoding quoted-printable... done")) 356 (and (> (- end start) 200)
333 357 (vm-unsaved-message "Decoding quoted-printable... done")))
334 (defun vm-mime-qp-encode-region (start end) 358
335 (vm-unsaved-message "Encoding quoted-printable...") 359 (defun vm-mime-qp-encode-region (start end &optional Q-encoding)
360 (and (> (- end start) 200)
361 (vm-unsaved-message "Encoding quoted-printable..."))
336 (let ((work-buffer nil) 362 (let ((work-buffer nil)
337 (buf (current-buffer)) 363 (buf (current-buffer))
338 (cols 0) 364 (cols 0)
339 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) 365 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
340 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) 366 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
363 1 nil work-buffer) 389 1 nil work-buffer)
364 (setq cols (+ cols 3))) 390 (setq cols (+ cols 3)))
365 (t (vm-insert-char char 1 nil work-buffer) 391 (t (vm-insert-char char 1 nil work-buffer)
366 (vm-increment cols))) 392 (vm-increment cols)))
367 (cond ((> cols 70) 393 (cond ((> cols 70)
368 (vm-insert-char ?= 1 nil work-buffer) 394 (setq cols 0)
369 (vm-insert-char ?\n 1 nil work-buffer) 395 (if Q-encoding
370 (setq cols 0))) 396 nil
397 (vm-insert-char ?= 1 nil work-buffer)
398 (vm-insert-char ?\n 1 nil work-buffer))))
371 (vm-increment inputpos)) 399 (vm-increment inputpos))
372 (or (markerp end) (setq end (vm-marker end))) 400 (or (markerp end) (setq end (vm-marker end)))
373 (goto-char start) 401 (goto-char start)
374 (insert-buffer-substring work-buffer) 402 (insert-buffer-substring work-buffer)
375 (delete-region (point) end)) 403 (delete-region (point) end)
376 (and work-buffer (kill-buffer work-buffer)))) 404 (and (> (- end start) 200)
377 (vm-unsaved-message "Encoding quoted-printable... done")) 405 (vm-unsaved-message "Encoding quoted-printable... done"))
406 (- end start))
407 (and work-buffer (kill-buffer work-buffer)))))
378 408
379 (defun vm-decode-mime-message-headers (m) 409 (defun vm-decode-mime-message-headers (m)
380 (let ((case-fold-search t) 410 (let ((case-fold-search t)
381 (buffer-read-only nil) 411 (buffer-read-only nil)
382 charset encoding match-start match-end start end) 412 charset encoding match-start match-end start end)
428 (t (vm-mime-error "unknown encoded word encoding, %s" 458 (t (vm-mime-error "unknown encoded word encoding, %s"
429 encoding))) 459 encoding)))
430 (vm-mime-charset-decode-region charset start end) 460 (vm-mime-charset-decode-region charset start end)
431 (delete-region match-start start)))))) 461 (delete-region match-start start))))))
432 462
433 (defun vm-decode-mime-encoded-words-maybe (string) 463 (defun vm-decode-mime-encoded-words-in-string (string)
434 (if (and vm-display-using-mime 464 (if (and vm-display-using-mime
435 (string-match vm-mime-encoded-word-regexp string)) 465 (string-match vm-mime-encoded-word-regexp string))
436 (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words) 466 (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words)
437 string )) 467 string ))
438 468
439 (defun vm-mime-parse-content-header (string &optional sepchar) 469 (defun vm-reencode-mime-encoded-words ()
470 (let ((charset nil)
471 start coding pos q-encoding
472 old-size
473 (case-fold-search t)
474 (done nil))
475 (save-excursion
476 (setq start (point-min))
477 (while (not done)
478 (setq charset (get-text-property start 'vm-charset))
479 (setq pos (next-single-property-change start 'vm-charset))
480 (or pos (setq pos (point-max) done t))
481 (if charset
482 (progn
483 (message " pos = %d start = %d" pos start)
484 (if (setq coding (get-text-property start 'vm-coding))
485 (progn
486 (setq old-size (buffer-size))
487 (encode-coding-region start pos coding)
488 (setq pos (+ pos (- (buffer-size) old-size)))))
489 (message " pos = %d start = %d" pos start)
490 (setq pos
491 (+ start
492 (if (setq q-encoding
493 (string-match "^iso-8859-\\|^us-ascii"
494 charset))
495 (vm-mime-Q-encode-region start pos)
496 (vm-mime-B-encode-region start pos))))
497 (message " pos = %d start = %d" pos start)
498 (goto-char pos)
499 (insert "?=")
500 (setq pos (point))
501 (goto-char start)
502 (insert "=?" charset "?" (if q-encoding "Q" "B") "?")))
503 (setq start pos)))))
504
505 (defun vm-reencode-mime-encoded-words-in-string (string)
506 (if (and vm-display-using-mime
507 (text-property-any 0 (length string) 'vm-string t string))
508 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words)
509 string ))
510
511 (defun vm-mime-parse-content-header (string &optional sepchar keep-quotes)
440 (if (null string) 512 (if (null string)
441 () 513 ()
442 (let ((work-buffer nil)) 514 (let ((work-buffer nil))
443 (save-excursion 515 (save-excursion
444 (unwind-protect 516 (unwind-protect
472 (skip-chars-forward sp+sepchar) 544 (skip-chars-forward sp+sepchar)
473 (setq start (point))) 545 (setq start (point)))
474 ((looking-at " \t\n\r\f") 546 ((looking-at " \t\n\r\f")
475 (skip-chars-forward " \t\n\r\f")) 547 (skip-chars-forward " \t\n\r\f"))
476 ((= char ?\") 548 ((= char ?\")
477 (delete-char 1) 549 (let ((done nil))
478 (cond ((= (char-after (point)) ?\") 550 (if keep-quotes
479 (delete-char 1)) 551 (forward-char 1)
480 ((re-search-forward "[^\\]\"" nil 0) 552 (delete-char 1))
481 (delete-char -1)))) 553 (while (not done)
554 (if (null (re-search-forward "[\\\"]" nil t))
555 (setq done t)
556 (setq char (char-after (1- (point))))
557 (cond ((char-equal char ?\\)
558 (delete-char -1)
559 (if (eobp)
560 (setq done t)
561 (forward-char 1)))
562 (t (if (not keep-quotes)
563 (delete-char -1))
564 (setq done t)))))))
482 ((= char ?\() 565 ((= char ?\()
483 (let ((parens 1) 566 (let ((done nil)
484 (pos (point))) 567 (pos (point))
568 (parens 1))
485 (forward-char 1) 569 (forward-char 1)
486 (while (and (not (eobp)) (not (zerop parens))) 570 (while (not done)
487 (re-search-forward "[()]" nil 0) 571 (if (null (re-search-forward "[\\()]" nil t))
488 (cond ((or (eobp) 572 (setq done t)
489 (= (char-after (- (point) 2)) ?\\))) 573 (setq char (char-after (1- (point))))
490 ((= (preceding-char) ?\() 574 (cond ((char-equal char ?\\)
491 (setq parens (1+ parens))) 575 (if (eobp)
492 (t 576 (setq done t)
493 (setq parens (1- parens))))) 577 (forward-char 1)))
578 ((char-equal char ?\()
579 (setq parens (1+ parens)))
580 (t
581 (setq parens (1- parens)
582 done (zerop parens))))))
494 (delete-region pos (point)))))) 583 (delete-region pos (point))))))
495 (setq s (buffer-substring start (point))) 584 (setq s (buffer-substring start (point)))
496 (if (and (null (string-match "^[\t\f\n\r ]+$" s)) 585 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
497 (not (string= s ""))) 586 (not (string= s "")))
498 (setq list (cons s list))) 587 (setq list (cons s list)))
511 (vm-match-header))) 600 (vm-match-header)))
512 (vm-matched-header-contents) 601 (vm-matched-header-contents)
513 nil ))))) 602 nil )))))
514 603
515 (defun vm-mime-parse-entity (&optional m default-type default-encoding) 604 (defun vm-mime-parse-entity (&optional m default-type default-encoding)
516 (let ((case-fold-search t) version type encoding id description 605 (let ((case-fold-search t) version type qtype encoding id description
517 disposition boundary boundary-regexp start 606 disposition qdisposition boundary boundary-regexp start
518 multipart-list c-t c-t-e done p returnval) 607 multipart-list c-t c-t-e done p returnval)
519 (and m (vm-unsaved-message "Parsing MIME message...")) 608 (and m (vm-unsaved-message "Parsing MIME message..."))
520 (prog1 609 (prog1
521 (catch 'return-value 610 (catch 'return-value
522 (save-excursion 611 (save-excursion
529 (if m 618 (if m
530 (progn 619 (progn
531 (setq version (vm-get-header-contents m "MIME-Version:") 620 (setq version (vm-get-header-contents m "MIME-Version:")
532 version (car (vm-mime-parse-content-header version)) 621 version (car (vm-mime-parse-content-header version))
533 type (vm-get-header-contents m "Content-Type:") 622 type (vm-get-header-contents m "Content-Type:")
623 qtype (vm-mime-parse-content-header type ?\; t)
534 type (vm-mime-parse-content-header type ?\;) 624 type (vm-mime-parse-content-header type ?\;)
535 encoding (or (vm-get-header-contents 625 encoding (or (vm-get-header-contents
536 m "Content-Transfer-Encoding:") 626 m "Content-Transfer-Encoding:")
537 "7bit") 627 "7bit")
538 encoding (car (vm-mime-parse-content-header encoding)) 628 encoding (car (vm-mime-parse-content-header encoding))
545 description) 635 description)
546 nil 636 nil
547 description)) 637 description))
548 disposition (vm-get-header-contents 638 disposition (vm-get-header-contents
549 m "Content-Disposition:") 639 m "Content-Disposition:")
640 qdisposition (and disposition
641 (vm-mime-parse-content-header
642 disposition ?\; t))
550 disposition (and disposition 643 disposition (and disposition
551 (vm-mime-parse-content-header 644 (vm-mime-parse-content-header
552 disposition ?\;))) 645 disposition ?\;)))
553 (widen) 646 (widen)
554 (narrow-to-region (vm-headers-of m) (vm-text-end-of m))) 647 (narrow-to-region (vm-headers-of m) (vm-text-end-of m)))
555 (goto-char (point-min)) 648 (goto-char (point-min))
556 (setq type (vm-mime-get-header-contents "Content-Type:") 649 (setq type (vm-mime-get-header-contents "Content-Type:")
650 qtype (or (vm-mime-parse-content-header type ?\; t)
651 default-type)
557 type (or (vm-mime-parse-content-header type ?\;) 652 type (or (vm-mime-parse-content-header type ?\;)
558 default-type) 653 default-type)
559 encoding (or (vm-mime-get-header-contents 654 encoding (or (vm-mime-get-header-contents
560 "Content-Transfer-Encoding:") 655 "Content-Transfer-Encoding:")
561 default-encoding) 656 default-encoding)
568 description) 663 description)
569 nil 664 nil
570 description)) 665 description))
571 disposition (vm-mime-get-header-contents 666 disposition (vm-mime-get-header-contents
572 "Content-Disposition:") 667 "Content-Disposition:")
668 qdisposition (and disposition
669 (vm-mime-parse-content-header
670 disposition ?\; t))
573 disposition (and disposition 671 disposition (and disposition
574 (vm-mime-parse-content-header 672 (vm-mime-parse-content-header
575 disposition ?\;)))) 673 disposition ?\;))))
576 (cond ((null m) t) 674 (cond ((null m) t)
577 ((null version) 675 ((null version)
579 ((string= version "1.0") t) 677 ((string= version "1.0") t)
580 (t (vm-mime-error "Unsupported MIME version: %s" version))) 678 (t (vm-mime-error "Unsupported MIME version: %s" version)))
581 (cond ((and m (null type)) 679 (cond ((and m (null type))
582 (throw 'return-value 680 (throw 'return-value
583 (vector '("text/plain" "charset=us-ascii") 681 (vector '("text/plain" "charset=us-ascii")
584 encoding id description disposition 682 '("text/plain" "charset=us-ascii")
683 encoding id description
684 disposition qdisposition
585 (vm-headers-of m) 685 (vm-headers-of m)
586 (vm-text-of m) 686 (vm-text-of m)
587 (vm-text-end-of m) 687 (vm-text-end-of m)
588 nil nil nil ))) 688 nil nil nil )))
589 ((null type) 689 ((null type)
590 (goto-char (point-min)) 690 (goto-char (point-min))
591 (or (re-search-forward "^\n\\|\n\\'" nil t) 691 (or (re-search-forward "^\n\\|\n\\'" nil t)
592 (vm-mime-error "MIME part missing header/body separator line")) 692 (vm-mime-error "MIME part missing header/body separator line"))
593 (vector default-type encoding id description disposition 693 (vector default-type default-type
694 encoding id description
695 disposition qdisposition
594 (vm-marker (point-min)) 696 (vm-marker (point-min))
595 (vm-marker (point)) 697 (vm-marker (point))
596 (vm-marker (point-max)) 698 (vm-marker (point-max))
597 nil nil nil )) 699 nil nil nil ))
598 ((null (string-match "[^/ ]+/[^/ ]+" (car type))) 700 ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
615 c-t-e "7bit") 717 c-t-e "7bit")
616 (goto-char (point-min)) 718 (goto-char (point-min))
617 (or (re-search-forward "^\n\\|\n\\'" nil t) 719 (or (re-search-forward "^\n\\|\n\\'" nil t)
618 (vm-mime-error "MIME part missing header/body separator line")) 720 (vm-mime-error "MIME part missing header/body separator line"))
619 (throw 'return-value 721 (throw 'return-value
620 (vector type encoding id description disposition 722 (vector type qtype encoding id description
723 disposition qdisposition
621 (vm-marker (point-min)) 724 (vm-marker (point-min))
622 (vm-marker (point)) 725 (vm-marker (point))
623 (vm-marker (point-max)) 726 (vm-marker (point-max))
624 (list 727 (list
625 (save-restriction 728 (save-restriction
626 (narrow-to-region (point) (point-max)) 729 (narrow-to-region (point) (point-max))
627 (vm-mime-parse-entity nil c-t c-t-e))) 730 (vm-mime-parse-entity-safe nil c-t
731 c-t-e)))
628 nil ))) 732 nil )))
629 (t 733 (t
630 (goto-char (point-min)) 734 (goto-char (point-min))
631 (or (re-search-forward "^\n\\|\n\\'" nil t) 735 (or (re-search-forward "^\n\\|\n\\'" nil t)
632 (vm-mime-error "MIME part missing header/body separator line")) 736 (vm-mime-error "MIME part missing header/body separator line"))
633 (throw 'return-value 737 (throw 'return-value
634 (vector type encoding id description disposition 738 (vector type qtype encoding id description
739 disposition qdisposition
635 (vm-marker (point-min)) 740 (vm-marker (point-min))
636 (vm-marker (point)) 741 (vm-marker (point))
637 (vm-marker (point-max)) 742 (vm-marker (point-max))
638 nil nil )))) 743 nil nil ))))
639 (setq p (cdr type) 744 (setq p (cdr type)
645 (setq p (cdr p)))) 750 (setq p (cdr p))))
646 (or boundary 751 (or boundary
647 (vm-mime-error 752 (vm-mime-error
648 "Boundary parameter missing in %s type specification" 753 "Boundary parameter missing in %s type specification"
649 (car type))) 754 (car type)))
650 (setq boundary-regexp (regexp-quote boundary) 755 ;; the \' in the regexp is to "be liberal" in the
651 boundary-regexp (concat "^--" boundary-regexp "\\(--\\)?\n")) 756 ;; face of broken software that does not add a line
757 ;; break after the final boundary of a nested
758 ;; multipart entity.
759 (setq boundary-regexp
760 (concat "^--" (regexp-quote boundary)
761 "\\(--\\)?[ \t]*\\(\n\\|\\'\\)"))
652 (goto-char (point-min)) 762 (goto-char (point-min))
653 (setq start nil 763 (setq start nil
654 multipart-list nil 764 multipart-list nil
655 done nil) 765 done nil)
656 (while (and (not done) (re-search-forward boundary-regexp nil t)) 766 (while (and (not done) (re-search-forward boundary-regexp nil t))
669 (if (not done) 779 (if (not done)
670 (vm-mime-error "final %s boundary missing" boundary)) 780 (vm-mime-error "final %s boundary missing" boundary))
671 (goto-char (point-min)) 781 (goto-char (point-min))
672 (or (re-search-forward "^\n\\|\n\\'" nil t) 782 (or (re-search-forward "^\n\\|\n\\'" nil t)
673 (vm-mime-error "MIME part missing header/body separator line")) 783 (vm-mime-error "MIME part missing header/body separator line"))
674 (vector type encoding id description disposition 784 (vector type qtype encoding id description
785 disposition qdisposition
675 (vm-marker (point-min)) 786 (vm-marker (point-min))
676 (vm-marker (point)) 787 (vm-marker (point))
677 (vm-marker (point-max)) 788 (vm-marker (point-max))
678 (nreverse multipart-list) 789 (nreverse multipart-list)
679 nil ))))) 790 nil )))))
697 nil 0) 808 nil 0)
698 (vm-marker (point))))) 809 (vm-marker (point)))))
699 (text-end (if m 810 (text-end (if m
700 (vm-text-end-of m) 811 (vm-text-end-of m)
701 (vm-marker (point-max))))) 812 (vm-marker (point-max)))))
702 (vector c-t 813 (vector c-t c-t
703 (vm-determine-proper-content-transfer-encoding text text-end) 814 (vm-determine-proper-content-transfer-encoding text text-end)
704 nil 815 nil
705 ;; cram the error message into the description slot 816 ;; cram the error message into the description slot
706 (car error-data) 817 (car (cdr error-data))
707 ;; mark as an attachment to improve the chance that the user 818 ;; mark as an attachment to improve the chance that the user
708 ;; will see the description. 819 ;; will see the description.
709 '("attachment") 820 '("attachment") '("attachment")
710 header 821 header
711 text 822 text
712 text-end))))) 823 text-end)))))
713 824
714 (defun vm-mime-get-xxx-parameter (layout name param-list) 825 (defun vm-mime-get-xxx-parameter (layout name param-list)
764 vm-message-pointer (list nil) 875 vm-message-pointer (list nil)
765 vm-mail-buffer mail-buffer 876 vm-mail-buffer mail-buffer
766 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 877 mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
767 (vm-menu-support-possible-p) 878 (vm-menu-support-possible-p)
768 (vm-menu-mode-menu)) 879 (vm-menu-mode-menu))
880 ;; Default to binary file type for DOS/NT.
881 buffer-file-type t
882 ;; Tell XEmacs/MULE not to mess with the text on writes.
769 buffer-read-only t 883 buffer-read-only t
770 mode-line-format vm-mode-line-format) 884 mode-line-format vm-mode-line-format)
885 (and (fboundp 'set-file-coding-system)
886 (set-file-coding-system 'binary t))
771 (cond ((vm-fsfemacs-19-p) 887 (cond ((vm-fsfemacs-19-p)
772 ;; need to do this outside the let because 888 ;; need to do this outside the let because
773 ;; loading disp-table initializes 889 ;; loading disp-table initializes
774 ;; standard-display-table. 890 ;; standard-display-table.
775 (require 'disp-table) 891 (require 'disp-table)
783 (and (vm-toolbar-support-possible-p) vm-use-toolbar 899 (and (vm-toolbar-support-possible-p) vm-use-toolbar
784 (vm-toolbar-install-toolbar)) 900 (vm-toolbar-install-toolbar))
785 (and (vm-menu-support-possible-p) 901 (and (vm-menu-support-possible-p)
786 (vm-menu-install-menus))) 902 (vm-menu-install-menus)))
787 (setq vm-presentation-buffer-handle b))) 903 (setq vm-presentation-buffer-handle b)))
788 ;; do this (widen) outside save-restricton intentionally. since
789 ;; we're using the presentation buffer, make the folder
790 ;; buffer unpretty so maybe the user gets the idea.
791 ;;(widen)
792 ;; widening isn't enough. users just complain that "I'm
793 ;; looking at the wrong message." Curse their miserable hides.
794 ;; bury the buffer so they'll have a tough time finding it.
795 (bury-buffer (current-buffer))
796 (setq b vm-presentation-buffer-handle 904 (setq b vm-presentation-buffer-handle
797 vm-presentation-buffer vm-presentation-buffer-handle 905 vm-presentation-buffer vm-presentation-buffer-handle
798 vm-mime-decoded nil) 906 vm-mime-decoded nil)
799 (save-excursion 907 (save-excursion
800 (set-buffer (vm-buffer-of real-m)) 908 (set-buffer (vm-buffer-of real-m))
837 (setcar vm-message-pointer mm))))) 945 (setcar vm-message-pointer mm)))))
838 946
839 (fset 'vm-presentation-mode 'vm-mode) 947 (fset 'vm-presentation-mode 'vm-mode)
840 (put 'vm-presentation-mode 'mode-class 'special) 948 (put 'vm-presentation-mode 'mode-class 'special)
841 949
950 (defvar file-coding-system)
951
842 (defun vm-determine-proper-charset (beg end) 952 (defun vm-determine-proper-charset (beg end)
843 (save-excursion 953 (save-excursion
844 (save-restriction 954 (save-restriction
845 (narrow-to-region beg end) 955 (narrow-to-region beg end)
846 (catch 'done 956 (catch 'done
847 (goto-char (point-min)) 957 (goto-char (point-min))
848 (and (re-search-forward "[^\000-\177]" nil t) 958 (if (vm-xemacs-mule-p)
849 (throw 'done (or vm-mime-8bit-composition-charset "iso-8859-1"))) 959 (let ((charsets (delq 'ascii (charsets-in-region beg end))))
850 (throw 'done "us-ascii"))))) 960 (cond ((null charsets)
961 "us-ascii")
962 ((cdr charsets)
963 (or (car (cdr
964 (assoc (coding-system-name file-coding-system)
965 vm-mime-mule-coding-to-charset-alist)))
966 "iso-2022-jp"))
967 (t
968 (or (car (cdr
969 (vm-string-assoc
970 (car charsets)
971 vm-mime-mule-charset-to-charset-alist)))
972 "unknown"))))
973 (and (re-search-forward "[^\000-\177]" nil t)
974 (throw 'done (or vm-mime-8bit-composition-charset
975 "iso-8859-1")))
976 (throw 'done "us-ascii"))))))
851 977
852 (defun vm-determine-proper-content-transfer-encoding (beg end) 978 (defun vm-determine-proper-content-transfer-encoding (beg end)
853 (save-excursion 979 (save-excursion
854 (save-restriction 980 (save-restriction
855 (narrow-to-region beg end) 981 (narrow-to-region beg end)
921 ((or (vm-mime-types-match "text/plain" type) 1047 ((or (vm-mime-types-match "text/plain" type)
922 (vm-mime-types-match "text/enriched" type)) 1048 (vm-mime-types-match "text/enriched" type))
923 (let ((charset (or (vm-mime-get-parameter layout "charset") 1049 (let ((charset (or (vm-mime-get-parameter layout "charset")
924 "us-ascii"))) 1050 "us-ascii")))
925 (vm-mime-charset-internally-displayable-p charset))) 1051 (vm-mime-charset-internally-displayable-p charset)))
926 ((vm-mime-types-match "text/html" type) 1052 ;; commented out until I decide whether W3 is safe to use in
927 (condition-case () 1053 ;; light of the porposed javascript extension and the possibility
928 (progn (require 'w3) 1054 ;; of executing arbitrary Emacs-Lisp code embedded in a page.
929 (fboundp 'w3-region)) 1055 ;;
930 (error nil))) 1056 ;; ((vm-mime-types-match "text/html" type)
1057 ;; (condition-case ()
1058 ;; (progn (require 'w3)
1059 ;; (fboundp 'w3-region))
1060 ;; (error nil)))
931 (t nil)))) 1061 (t nil))))
932 1062
933 (defun vm-mime-can-convert (type) 1063 (defun vm-mime-can-convert (type)
934 (let ((alist vm-mime-type-converter-alist) 1064 (let ((alist vm-mime-type-converter-alist)
935 ;; fake layout. make it the wrong length so an error will 1065 ;; fake layout. make it the wrong length so an error will
967 (set-buffer-modified-p nil) 1097 (set-buffer-modified-p nil)
968 (vm-unsaved-message "Converting %s to %s... done" 1098 (vm-unsaved-message "Converting %s to %s... done"
969 (car (vm-mm-layout-type layout)) 1099 (car (vm-mm-layout-type layout))
970 (nth 1 ooo)) 1100 (nth 1 ooo))
971 (vector (list (nth 1 ooo)) 1101 (vector (list (nth 1 ooo))
1102 (list (nth 1 ooo))
972 "binary" 1103 "binary"
973 (vm-mm-layout-id layout) 1104 (vm-mm-layout-id layout)
974 (vm-mm-layout-description layout) 1105 (vm-mm-layout-description layout)
975 (vm-mm-layout-disposition layout) 1106 (vm-mm-layout-disposition layout)
1107 (vm-mm-layout-qdisposition layout)
976 (vm-marker (point-min)) 1108 (vm-marker (point-min))
977 (vm-marker (point)) 1109 (vm-marker (point))
978 (vm-marker (point-max)) 1110 (vm-marker (point-max))
979 nil 1111 nil
980 nil )))) 1112 nil ))))
1095 (error "Message needs no decoding.")) 1227 (error "Message needs no decoding."))
1096 (or vm-presentation-buffer 1228 (or vm-presentation-buffer
1097 ;; maybe user killed it 1229 ;; maybe user killed it
1098 (error "No presentation buffer.")) 1230 (error "No presentation buffer."))
1099 (set-buffer vm-presentation-buffer) 1231 (set-buffer vm-presentation-buffer)
1232 (if (and (interactive-p) (eq vm-system-state 'previewing))
1233 (let ((vm-display-using-mime nil))
1234 (vm-show-current-message)))
1100 (setq m (car vm-message-pointer)) 1235 (setq m (car vm-message-pointer))
1101 (vm-save-restriction 1236 (vm-save-restriction
1102 (widen) 1237 (widen)
1103 (goto-char (vm-text-of m)) 1238 (goto-char (vm-text-of m))
1104 (let ((buffer-read-only nil) 1239 (let ((buffer-read-only nil)
1178 t ) 1313 t )
1179 1314
1180 (defun vm-mime-display-button-text (layout) 1315 (defun vm-mime-display-button-text (layout)
1181 (vm-mime-display-button-xxxx layout t)) 1316 (vm-mime-display-button-xxxx layout t))
1182 1317
1183 (defun vm-mime-display-internal-text/html (layout) 1318 ;; commented out until I decide whether W3 is safe to use in
1184 (let ((buffer-read-only nil) 1319 ;; light of the proposed javascript extension and the possibility
1185 (work-buffer nil)) 1320 ;; of executing arbitrary Emacs-Lisp code embedded in a page.
1186 (vm-unsaved-message "Inlining text/html, be patient...") 1321 ;;
1187 ;; w3-region is not as tame as we would like. 1322 ;;(defun vm-mime-display-internal-text/html (layout)
1188 ;; make sure the yoke is firmly attached. 1323 ;; (let ((buffer-read-only nil)
1189 (unwind-protect 1324 ;; (work-buffer nil))
1190 (progn 1325 ;; (vm-unsaved-message "Inlining text/html, be patient...")
1191 (save-excursion 1326 ;; ;; w3-region is not as tame as we would like.
1192 (set-buffer (setq work-buffer 1327 ;; ;; make sure the yoke is firmly attached.
1193 (generate-new-buffer " *workbuf*"))) 1328 ;; (unwind-protect
1194 (vm-mime-insert-mime-body layout) 1329 ;; (progn
1195 (vm-mime-transfer-decode-region layout (point-min) (point-max)) 1330 ;; (save-excursion
1196 (save-excursion 1331 ;; (set-buffer (setq work-buffer
1197 (save-window-excursion 1332 ;; (generate-new-buffer " *workbuf*")))
1198 (w3-region (point-min) (point-max))))) 1333 ;; (vm-mime-insert-mime-body layout)
1199 (insert-buffer-substring work-buffer)) 1334 ;; (vm-mime-transfer-decode-region layout (point-min) (point-max))
1200 (and work-buffer (kill-buffer work-buffer))) 1335 ;; (save-excursion
1201 (vm-unsaved-message "Inlining text/html... done") 1336 ;; (save-window-excursion
1202 t )) 1337 ;; (w3-region (point-min) (point-max)))))
1338 ;; (insert-buffer-substring work-buffer))
1339 ;; (and work-buffer (kill-buffer work-buffer)))
1340 ;; (vm-unsaved-message "Inlining text/html... done")
1341 ;; t ))
1203 1342
1204 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) 1343 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls)
1205 (let ((start (point)) end 1344 (let ((start (point)) end old-size
1206 (buffer-read-only nil) 1345 (buffer-read-only nil)
1207 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) 1346 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
1208 (if (not (vm-mime-charset-internally-displayable-p charset)) 1347 (if (not (vm-mime-charset-internally-displayable-p charset))
1209 nil 1348 nil
1210 (vm-mime-insert-mime-body layout) 1349 (vm-mime-insert-mime-body layout)
1211 (setq end (point-marker)) 1350 (setq end (point-marker))
1212 (vm-mime-transfer-decode-region layout start end) 1351 (vm-mime-transfer-decode-region layout start end)
1352 (setq old-size (buffer-size))
1213 (vm-mime-charset-decode-region charset start end) 1353 (vm-mime-charset-decode-region charset start end)
1354 (set-marker end (+ end (- (buffer-size) old-size)))
1214 (or ignore-urls (vm-energize-urls-in-message-region start end)) 1355 (or ignore-urls (vm-energize-urls-in-message-region start end))
1356 (goto-char end)
1215 t ))) 1357 t )))
1216 1358
1217 (defun vm-mime-display-internal-text/enriched (layout) 1359 (defun vm-mime-display-internal-text/enriched (layout)
1218 (require 'enriched) 1360 (require 'enriched)
1219 (let ((start (point)) end 1361 (let ((start (point)) end
1248 (cond ((or (null tempfile) (null (file-exists-p tempfile))) 1390 (cond ((or (null tempfile) (null (file-exists-p tempfile)))
1249 (vm-mime-insert-mime-body layout) 1391 (vm-mime-insert-mime-body layout)
1250 (setq end (point-marker)) 1392 (setq end (point-marker))
1251 (vm-mime-transfer-decode-region layout start end) 1393 (vm-mime-transfer-decode-region layout start end)
1252 (setq tempfile (vm-make-tempfile-name)) 1394 (setq tempfile (vm-make-tempfile-name))
1253 ;; Tell DOS/Windows NT whether the file is binary 1395 (let ((buffer-file-type buffer-file-type)
1254 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1396 file-coding-system)
1255 (write-region start end tempfile nil 0) 1397 ;; Tell DOS/Windows NT whether the file is binary
1398 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1399 ;; Tell XEmacs/MULE not to mess with the bits unless
1400 ;; this is a text type.
1401 (if (fboundp 'set-file-coding-system)
1402 (if (vm-mime-text-type-p layout)
1403 (set-file-coding-system 'no-conversion nil)
1404 (set-file-coding-system 'binary t)))
1405 (write-region start end tempfile nil 0))
1256 (delete-region start end) 1406 (delete-region start end)
1257 (save-excursion 1407 (save-excursion
1258 (vm-select-folder-buffer) 1408 (vm-select-folder-buffer)
1259 (setq vm-folder-garbage-alist 1409 (setq vm-folder-garbage-alist
1260 (cons (cons tempfile 'delete-file) 1410 (cons (cons tempfile 'delete-file)
1281 (defun vm-mime-display-internal-application/octet-stream (layout) 1431 (defun vm-mime-display-internal-application/octet-stream (layout)
1282 (if (vectorp layout) 1432 (if (vectorp layout)
1283 (let ((buffer-read-only nil) 1433 (let ((buffer-read-only nil)
1284 (description (vm-mm-layout-description layout))) 1434 (description (vm-mm-layout-description layout)))
1285 (vm-mime-insert-button 1435 (vm-mime-insert-button
1286 (format "%-35s [%s to save to a file]" 1436 (format "%-35.35s [%s to save to a file]"
1287 (vm-mime-layout-description layout) 1437 (vm-mime-layout-description layout)
1288 (if (vm-mouse-support-possible-p) 1438 (if (vm-mouse-support-possible-p)
1289 "Click mouse-2" 1439 "Click mouse-2"
1290 "Press RETURN")) 1440 "Press RETURN"))
1291 (function 1441 (function
1365 (car (vm-mm-layout-parts layout))))))) 1515 (car (vm-mm-layout-parts layout)))))))
1366 (vm-decode-mime-layout best-layout))) 1516 (vm-decode-mime-layout best-layout)))
1367 1517
1368 (defun vm-mime-display-button-multipart/parallel (layout) 1518 (defun vm-mime-display-button-multipart/parallel (layout)
1369 (vm-mime-insert-button 1519 (vm-mime-insert-button
1370 (format "%-35s [%s to display in parallel]" 1520 (format "%-35.35s [%s to display in parallel]"
1371 (vm-mime-layout-description layout) 1521 (vm-mime-layout-description layout)
1372 (if (vm-mouse-support-possible-p) 1522 (if (vm-mouse-support-possible-p)
1373 "Click mouse-2" 1523 "Click mouse-2"
1374 "Press RETURN")) 1524 "Press RETURN"))
1375 (function 1525 (function
1384 1534
1385 (defun vm-mime-display-internal-multipart/digest (layout) 1535 (defun vm-mime-display-internal-multipart/digest (layout)
1386 (if (vectorp layout) 1536 (if (vectorp layout)
1387 (let ((buffer-read-only nil)) 1537 (let ((buffer-read-only nil))
1388 (vm-mime-insert-button 1538 (vm-mime-insert-button
1389 (format "%-35s [%s to display]" 1539 (format "%-35.35s [%s to display]"
1390 (vm-mime-layout-description layout) 1540 (vm-mime-layout-description layout)
1391 (if (vm-mouse-support-possible-p) 1541 (if (vm-mouse-support-possible-p)
1392 "Click mouse-2" 1542 "Click mouse-2"
1393 "Press RETURN")) 1543 "Press RETURN"))
1394 (function 1544 (function
1416 1566
1417 (defun vm-mime-display-internal-message/rfc822 (layout) 1567 (defun vm-mime-display-internal-message/rfc822 (layout)
1418 (if (vectorp layout) 1568 (if (vectorp layout)
1419 (let ((buffer-read-only nil)) 1569 (let ((buffer-read-only nil))
1420 (vm-mime-insert-button 1570 (vm-mime-insert-button
1421 (format "%-35s [%s to display]" 1571 (format "%-35.35s [%s to display]"
1422 (vm-mime-layout-description layout) 1572 (vm-mime-layout-description layout)
1423 (if (vm-mouse-support-possible-p) 1573 (if (vm-mouse-support-possible-p)
1424 "Click mouse-2" 1574 "Click mouse-2"
1425 "Press RETURN")) 1575 "Press RETURN"))
1426 (function 1576 (function
1453 (if (vectorp layout) 1603 (if (vectorp layout)
1454 (let ((buffer-read-only nil) 1604 (let ((buffer-read-only nil)
1455 (number (vm-mime-get-parameter layout "number")) 1605 (number (vm-mime-get-parameter layout "number"))
1456 (total (vm-mime-get-parameter layout "total"))) 1606 (total (vm-mime-get-parameter layout "total")))
1457 (vm-mime-insert-button 1607 (vm-mime-insert-button
1458 (format "%-35s [%s to attempt assembly]" 1608 (format "%-35.35s [%s to attempt assembly]"
1459 (concat (vm-mime-layout-description layout) 1609 (concat (vm-mime-layout-description layout)
1460 (and number (concat ", part " number)) 1610 (and number (concat ", part " number))
1461 (and number total (concat " of " total))) 1611 (and number total (concat " of " total)))
1462 (if (vm-mouse-support-possible-p) 1612 (if (vm-mouse-support-possible-p)
1463 "Click mouse-2" 1613 "Click mouse-2"
1593 (setq g (vm-mm-layout-cache layout)) 1743 (setq g (vm-mm-layout-cache layout))
1594 (vm-mime-insert-mime-body layout) 1744 (vm-mime-insert-mime-body layout)
1595 (setq end (point-marker)) 1745 (setq end (point-marker))
1596 (vm-mime-transfer-decode-region layout start end) 1746 (vm-mime-transfer-decode-region layout start end)
1597 (setq tempfile (vm-make-tempfile-name)) 1747 (setq tempfile (vm-make-tempfile-name))
1748 ;; coding system for presentation buffer is binary
1598 (write-region start end tempfile nil 0) 1749 (write-region start end tempfile nil 0)
1599 (vm-unsaved-message "Creating %s glyph..." name) 1750 (vm-unsaved-message "Creating %s glyph..." name)
1600 (setq g (make-glyph 1751 (setq g (make-glyph
1601 (list (vector feature ':file tempfile) 1752 (list (vector feature ':file tempfile)
1602 (vector 'string 1753 (vector 'string
1644 (setq tempfile (vm-mm-layout-cache layout)) 1795 (setq tempfile (vm-mm-layout-cache layout))
1645 (vm-mime-insert-mime-body layout) 1796 (vm-mime-insert-mime-body layout)
1646 (setq end (point-marker)) 1797 (setq end (point-marker))
1647 (vm-mime-transfer-decode-region layout start end) 1798 (vm-mime-transfer-decode-region layout start end)
1648 (setq tempfile (vm-make-tempfile-name)) 1799 (setq tempfile (vm-make-tempfile-name))
1800 ;; coding system for presentation buffer is binary
1649 (write-region start end tempfile nil 0) 1801 (write-region start end tempfile nil 0)
1650 (vm-set-mm-layout-cache layout tempfile) 1802 (vm-set-mm-layout-cache layout tempfile)
1651 (save-excursion 1803 (save-excursion
1652 (vm-select-folder-buffer) 1804 (vm-select-folder-buffer)
1653 (setq vm-folder-garbage-alist 1805 (setq vm-folder-garbage-alist
1661 nil )) 1813 nil ))
1662 1814
1663 (defun vm-mime-display-button-xxxx (layout disposable) 1815 (defun vm-mime-display-button-xxxx (layout disposable)
1664 (let ((description (vm-mime-layout-description layout))) 1816 (let ((description (vm-mime-layout-description layout)))
1665 (vm-mime-insert-button 1817 (vm-mime-insert-button
1666 (format "%-35s [%s to display]" 1818 (format "%-35.35s [%s to display]"
1667 description 1819 description
1668 (if (vm-mouse-support-possible-p) "Click mouse-2" "Press RETURN")) 1820 (if (vm-mouse-support-possible-p) "Click mouse-2" "Press RETURN"))
1669 (function 1821 (function
1670 (lambda (layout) 1822 (lambda (layout)
1671 (save-excursion 1823 (save-excursion
1695 (funcall (or function (extent-property e 'vm-mime-function)) 1847 (funcall (or function (extent-property e 'vm-mime-function))
1696 e)))))) 1848 e))))))
1697 1849
1698 ;; for the karking compiler 1850 ;; for the karking compiler
1699 (defvar vm-menu-mime-dispose-menu) 1851 (defvar vm-menu-mime-dispose-menu)
1852
1853 (defun vm-mime-set-extent-glyph-for-layout (e layout)
1854 (if (and (vm-xemacs-p) (fboundp 'make-glyph)
1855 (eq (device-type) 'x) (> (device-bitplanes) 15))
1856 (let ((type (car (vm-mm-layout-type layout)))
1857 (dir vm-image-directory)
1858 glyph)
1859 (setq glyph
1860 (cond ((vm-mime-types-match "text" type)
1861 (make-glyph (vector
1862 'xpm ':file
1863 (expand-file-name "document.xpm" dir))))
1864 ((vm-mime-types-match "image" type)
1865 (make-glyph (vector
1866 'gif ':file
1867 (expand-file-name "mona_stamp.gif" dir))))
1868 ((vm-mime-types-match "audio" type)
1869 (make-glyph (vector
1870 'xpm ':file
1871 (expand-file-name "audio_stamp.xpm" dir))))
1872 ((vm-mime-types-match "video" type)
1873 (make-glyph (vector
1874 'xpm ':file
1875 (expand-file-name "film.xpm" dir))))
1876 ((vm-mime-types-match "message" type)
1877 (make-glyph (vector
1878 'xpm ':file
1879 (expand-file-name "message.xpm" dir))))
1880 ((vm-mime-types-match "application" type)
1881 (make-glyph (vector
1882 'xpm ':file
1883 (expand-file-name "gear.xpm" dir))))
1884 ((vm-mime-types-match "multipart" type)
1885 (make-glyph (vector
1886 'xpm ':file
1887 (expand-file-name "stuffed_box.xpm" dir))))
1888 (t nil)))
1889 (and glyph (set-extent-begin-glyph e glyph)))))
1700 1890
1701 (defun vm-mime-insert-button (caption action layout disposable) 1891 (defun vm-mime-insert-button (caption action layout disposable)
1702 (let ((start (point)) e 1892 (let ((start (point)) e
1703 (keymap (make-sparse-keymap)) 1893 (keymap (make-sparse-keymap))
1704 (buffer-read-only nil)) 1894 (buffer-read-only nil))
1718 (if (fboundp 'make-overlay) 1908 (if (fboundp 'make-overlay)
1719 (setq e (make-overlay start (point) nil t nil)) 1909 (setq e (make-overlay start (point) nil t nil))
1720 (setq e (make-extent start (point))) 1910 (setq e (make-extent start (point)))
1721 (set-extent-property e 'start-open t) 1911 (set-extent-property e 'start-open t)
1722 (set-extent-property e 'end-open t)) 1912 (set-extent-property e 'end-open t))
1913 (vm-mime-set-extent-glyph-for-layout e layout)
1723 ;; for emacs 1914 ;; for emacs
1724 (vm-set-extent-property e 'mouse-face 'highlight) 1915 (vm-set-extent-property e 'mouse-face 'highlight)
1725 (vm-set-extent-property e 'local-map keymap) 1916 (vm-set-extent-property e 'local-map keymap)
1726 ;; for xemacs 1917 ;; for xemacs
1727 (vm-set-extent-property e 'highlight t) 1918 (vm-set-extent-property e 'highlight t)
1740 (setq default-filename 1931 (setq default-filename
1741 (vm-mime-get-disposition-parameter layout "filename"))) 1932 (vm-mime-get-disposition-parameter layout "filename")))
1742 (and default-filename 1933 (and default-filename
1743 (setq default-filename (file-name-nondirectory default-filename))) 1934 (setq default-filename (file-name-nondirectory default-filename)))
1744 (let ((work-buffer nil) 1935 (let ((work-buffer nil)
1745 ;; evade the XEmacs dialox box, yeccch. 1936 ;; evade the XEmacs dialog box, yeccch.
1746 (should-use-dialog-box nil) 1937 (use-dialog-box nil)
1938 (dir vm-mime-attachment-save-directory)
1939 (done nil)
1747 file) 1940 file)
1748 (setq file 1941 (while (not done)
1749 (read-file-name 1942 (setq file
1750 (if default-filename 1943 (read-file-name
1751 (format "Write MIME body to file (default %s): " 1944 (if default-filename
1752 default-filename) 1945 (format "Write MIME body to file (default %s): "
1753 "Write MIME body to file: ") 1946 default-filename)
1754 vm-mime-attachment-save-directory default-filename) 1947 "Write MIME body to file: ")
1755 file (expand-file-name file vm-mime-attachment-save-directory)) 1948 dir default-filename)
1949 file (expand-file-name file dir))
1950 (if (not (file-directory-p file))
1951 (setq done t)
1952 (if default-filename
1953 (message "%s is a directory" file)
1954 (error "%s is a directory" file))
1955 (sit-for 2)
1956 (setq dir file
1957 default-filename (if (string-match "/$" file)
1958 (concat file default-filename)
1959 (concat file "/" default-filename)))))
1756 (save-excursion 1960 (save-excursion
1757 (unwind-protect 1961 (unwind-protect
1758 (progn 1962 (progn
1759 (setq work-buffer (generate-new-buffer " *vm-work*")) 1963 (setq work-buffer (generate-new-buffer " *vm-work*"))
1760 (buffer-disable-undo work-buffer) 1964 (buffer-disable-undo work-buffer)
1761 (set-buffer work-buffer) 1965 (set-buffer work-buffer)
1762 ;; Tell DOS/Windows NT whether the file is binary 1966 ;; Tell DOS/Windows NT whether the file is binary
1763 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1967 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1968 ;; Tell XEmacs/MULE not to mess with the bits unless
1969 ;; this is a text type.
1970 (if (fboundp 'set-file-coding-system)
1971 (if (vm-mime-text-type-p layout)
1972 (set-file-coding-system 'no-conversion nil)
1973 (set-file-coding-system 'binary t)))
1764 (vm-mime-insert-mime-body layout) 1974 (vm-mime-insert-mime-body layout)
1765 (vm-mime-transfer-decode-region layout (point-min) (point-max)) 1975 (vm-mime-transfer-decode-region layout (point-min) (point-max))
1766 (or (not (file-exists-p file)) 1976 (or (not (file-exists-p file))
1767 (y-or-n-p "File exists, overwrite? ") 1977 (y-or-n-p "File exists, overwrite? ")
1768 (error "Aborted")) 1978 (error "Aborted"))
1876 (case-fold-search t)) 2086 (case-fold-search t))
1877 (and (eq (vm-mm-encoded-header m) 'none) 2087 (and (eq (vm-mm-encoded-header m) 'none)
1878 (or (not (vectorp o)) 2088 (or (not (vectorp o))
1879 (and (vm-mime-types-match "text/plain" 2089 (and (vm-mime-types-match "text/plain"
1880 (car (vm-mm-layout-type o))) 2090 (car (vm-mm-layout-type o)))
1881 (string-match "^\\(us-ascii\\|iso-8859-1\\)$" 2091 (let* ((charset (or (vm-mime-get-parameter o "charset")
1882 (or (vm-mime-get-parameter o "charset") 2092 "us-ascii")))
1883 "us-ascii")) 2093 (vm-string-member charset vm-mime-default-face-charsets))
1884 (string-match "^\\(7bit\\|8bit\\|binary\\)$" 2094 (string-match "^\\(7bit\\|8bit\\|binary\\)$"
1885 (vm-mm-layout-encoding o)))))))) 2095 (vm-mm-layout-encoding o))))))))
1886 2096
1887 (defun vm-mime-text-type-p (layout) 2097 (defun vm-mime-text-type-p (layout)
1888 (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) 2098 (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout)))
1889 (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) 2099 (vm-mime-types-match "message" (car (vm-mm-layout-type layout)))))
1890 2100
1891 (defun vm-mime-charset-internally-displayable-p (name) 2101 (defun vm-mime-charset-internally-displayable-p (name)
1892 (cond ((and (vm-xemacs-mule-p) (eq (device-type) 'x)) 2102 (cond ((and (vm-xemacs-mule-p) (eq (device-type) 'x))
1893 (cdr (assoc (downcase name) vm-mime-xemacs-mule-charset-alist))) 2103 (vm-string-assoc name vm-mime-mule-charset-to-coding-alist))
1894 ((vm-xemacs-p) 2104 ((vm-multiple-fonts-possible-p)
1895 (vm-member (downcase name) '("us-ascii" "iso-8859-1"))) 2105 (or (vm-string-member name vm-mime-default-face-charsets)
1896 ((vm-fsfemacs-19-p) 2106 (vm-string-assoc name vm-mime-charset-font-alist)))
1897 (vm-member (downcase name) '("us-ascii" "iso-8859-1"))))) 2107 (t
2108 (vm-string-member name vm-mime-default-face-charsets))))
1898 2109
1899 (defun vm-mime-find-message/partials (layout id) 2110 (defun vm-mime-find-message/partials (layout id)
1900 (let ((list nil) 2111 (let ((list nil)
1901 (type (vm-mm-layout-type layout))) 2112 (type (vm-mm-layout-type layout)))
1902 (cond ((vm-mime-types-match "multipart" (car type)) 2113 (cond ((vm-mime-types-match "multipart" (car type))
1931 (% (vm-abs (lsh (random) -8)) 2142 (% (vm-abs (lsh (random) -8))
1932 (length vm-mime-base64-alphabet)))) 2143 (length vm-mime-base64-alphabet))))
1933 (vm-increment i)) 2144 (vm-increment i))
1934 boundary )) 2145 boundary ))
1935 2146
1936 (defun vm-mime-attach-file (file type &optional charset) 2147 (defun vm-mime-attach-file (file type &optional charset description)
1937 "Attach a file to a VM composition buffer to be sent along with the message. 2148 "Attach a file to a VM composition buffer to be sent along with the message.
1938 The file is not inserted into the buffer and MIME encoded until 2149 The file is not inserted into the buffer and MIME encoded until
1939 you execute vm-mail-send or vm-mail-send-and-exit. A visible tag 2150 you execute vm-mail-send or vm-mail-send-and-exit. A visible tag
1940 indicating the existence of the attachment is placed in the 2151 indicating the existence of the attachment is placed in the
1941 composition buffer. You can move the attachment around or remove 2152 composition buffer. You can move the attachment around or remove
1943 attachment tag, the attachment will not be sent. 2154 attachment tag, the attachment will not be sent.
1944 2155
1945 First argument, FILE, is the name of the file to attach. Second 2156 First argument, FILE, is the name of the file to attach. Second
1946 argument, TYPE, is the MIME Content-Type of the file. Optional 2157 argument, TYPE, is the MIME Content-Type of the file. Optional
1947 third argument CHARSET is the character set of the attached 2158 third argument CHARSET is the character set of the attached
1948 document. This argument is only used for text types, and it 2159 document. This argument is only used for text types, and it is
1949 is ignored for other types. 2160 ignored for other types. Optional fourth argument DESCRIPTION
2161 should be a one line description of the file.
1950 2162
1951 When called interactively all arguments are read from the 2163 When called interactively all arguments are read from the
1952 minibuffer. 2164 minibuffer.
1953 2165
1954 This command is for attaching files that do not have a MIME 2166 This command is for attaching files that do not have a MIME
1959 (interactive 2171 (interactive
1960 ;; protect value of last-command and this-command 2172 ;; protect value of last-command and this-command
1961 (let ((last-command last-command) 2173 (let ((last-command last-command)
1962 (this-command this-command) 2174 (this-command this-command)
1963 (charset nil) 2175 (charset nil)
1964 file default-type type) 2176 description file default-type type)
1965 (if (null vm-send-using-mime) 2177 (if (null vm-send-using-mime)
1966 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) 2178 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
1967 (setq file (vm-read-file-name "Attach file: " nil nil t) 2179 (setq file (vm-read-file-name "Attach file: " nil nil t)
1968 default-type (or (vm-mime-default-type-from-filename file) 2180 default-type (or (vm-mime-default-type-from-filename file)
1969 "application/octet-stream") 2181 "application/octet-stream")
1974 type (if (> (length type) 0) type default-type)) 2186 type (if (> (length type) 0) type default-type))
1975 (if (vm-mime-types-match "text" type) 2187 (if (vm-mime-types-match "text" type)
1976 (setq charset (completing-read "Character set (default US-ASCII): " 2188 (setq charset (completing-read "Character set (default US-ASCII): "
1977 vm-mime-charset-completion-alist) 2189 vm-mime-charset-completion-alist)
1978 charset (if (> (length charset) 0) charset))) 2190 charset (if (> (length charset) 0) charset)))
1979 (list file type charset))) 2191 (setq description (read-string "One line description: "))
2192 (if (string-match "^[ \t]*$" description)
2193 (setq description nil))
2194 (list file type charset description)))
1980 (if (null vm-send-using-mime) 2195 (if (null vm-send-using-mime)
1981 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) 2196 (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable."))
1982 (if (file-directory-p file) 2197 (if (file-directory-p file)
1983 (error "%s is a directory, cannot attach" file)) 2198 (error "%s is a directory, cannot attach" file))
1984 (if (not (file-exists-p file)) 2199 (if (not (file-exists-p file))
1985 (error "No such file: %s" file)) 2200 (error "No such file: %s" file))
1986 (if (not (file-readable-p file)) 2201 (if (not (file-readable-p file))
1987 (error "You don't have permission to read %s" file)) 2202 (error "You don't have permission to read %s" file))
1988 (and charset (setq charset (list (concat "charset=" charset)))) 2203 (and charset (setq charset (list (concat "charset=" charset))))
1989 (vm-mime-attach-object file type charset nil)) 2204 (and description (setq description (vm-mime-scrub-description description)))
2205 (vm-mime-attach-object file type charset description nil))
1990 2206
1991 (defun vm-mime-attach-mime-file (file) 2207 (defun vm-mime-attach-mime-file (file)
1992 "Attach a MIME encoded file to a VM composition buffer to be sent 2208 "Attach a MIME encoded file to a VM composition buffer to be sent
1993 along with the message. 2209 along with the message.
1994 2210
2022 (error "%s is a directory, cannot attach" file)) 2238 (error "%s is a directory, cannot attach" file))
2023 (if (not (file-exists-p file)) 2239 (if (not (file-exists-p file))
2024 (error "No such file: %s" file)) 2240 (error "No such file: %s" file))
2025 (if (not (file-readable-p file)) 2241 (if (not (file-readable-p file))
2026 (error "You don't have permission to read %s" file)) 2242 (error "You don't have permission to read %s" file))
2027 (vm-mime-attach-object file "MIME file" nil t)) 2243 (vm-mime-attach-object file nil nil nil t))
2028 2244
2029 (defun vm-mime-attach-object (object type params mimed) 2245 (defun vm-mime-attach-object (object type params description mimed)
2030 (if (not (eq major-mode 'mail-mode)) 2246 (if (not (eq major-mode 'mail-mode))
2031 (error "Command must be used in a VM Mail mode buffer.")) 2247 (error "Command must be used in a VM Mail mode buffer."))
2032 (let ((start (point)) 2248 (let (start end e tag-string disposition)
2033 e tag-string) 2249 (if (< (point) (save-excursion (mail-text) (point)))
2034 (setq tag-string (format "[ATTACHMENT %s, %s]" object type)) 2250 (mail-text))
2251 (setq start (point)
2252 tag-string (format "[ATTACHMENT %s, %s]" object
2253 (or type "MIME file")))
2035 (insert tag-string "\n") 2254 (insert tag-string "\n")
2036 (cond ((fboundp 'make-overlay) 2255 (setq end (1- (point)))
2037 (setq e (make-overlay start (point) nil t nil)) 2256 ;; attach default filename for recipient if currently
2038 (overlay-put e 'face vm-mime-button-face)) 2257 ;; non-MIME. if already MIME'd don't do this because it
2258 ;; would override any content-disposition header already in
2259 ;; the attachment.
2260 (if (and (stringp object) (not mimed))
2261 (progn
2262 (if (or (vm-mime-types-match "application" type)
2263 (vm-mime-types-match "model" type))
2264 (setq disposition (list "attachment"))
2265 (setq disposition (list "inline")))
2266 (setq disposition (nconc disposition
2267 (list
2268 (concat "filename=\""
2269 (file-name-nondirectory object)
2270 "\""))))))
2271 (cond ((vm-fsfemacs-19-p)
2272 (put-text-property start end 'front-sticky nil)
2273 (put-text-property start end 'rear-nonsticky t)
2274 (put-text-property start end 'intangible object)
2275 (put-text-property start end 'face vm-mime-button-face)
2276 (put-text-property start end 'vm-mime-type type)
2277 (put-text-property start end 'vm-mime-object object)
2278 (put-text-property start end 'vm-mime-parameters params)
2279 (put-text-property start end 'vm-mime-description description)
2280 (put-text-property start end 'vm-mime-disposition disposition)
2281 (put-text-property start end 'vm-mime-encoded mimed)
2282 (put-text-property start end 'vm-mime-object object))
2039 ((fboundp 'make-extent) 2283 ((fboundp 'make-extent)
2040 (setq e (make-extent start (1- (point)))) 2284 (setq e (make-extent start end))
2041 (set-extent-property e 'start-open t) 2285 (set-extent-property e 'start-open t)
2042 (set-extent-property e 'face vm-mime-button-face))) 2286 (set-extent-property e 'face vm-mime-button-face)
2043 (vm-set-extent-property e 'duplicable t) 2287 (vm-set-extent-property e 'duplicable t)
2044 ;; crashes XEmacs 2288 (vm-set-extent-property e 'vm-mime-type type)
2045 ;; (vm-set-extent-property e 'replicating t) 2289 (vm-set-extent-property e 'vm-mime-object object)
2046 (vm-set-extent-property e 'vm-mime-type type) 2290 (vm-set-extent-property e 'vm-mime-parameters params)
2047 (vm-set-extent-property e 'vm-mime-object object) 2291 (vm-set-extent-property e 'vm-mime-description description)
2048 (vm-set-extent-property e 'vm-mime-params params) 2292 (vm-set-extent-property e 'vm-mime-disposition disposition)
2049 (vm-set-extent-property e 'vm-mime-encoded mimed))) 2293 (vm-set-extent-property e 'vm-mime-encoded mimed)))))
2294
2295 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end
2296 &optional old-size)
2297 (cond ((null after) nil)
2298 ((= start (overlay-start overlay))
2299 (move-overlay overlay end (overlay-end overlay)))
2300 ((= start (overlay-end overlay))
2301 (move-overlay overlay (overlay-start overlay) start))))
2302
2303 (defun vm-mime-fake-attachment-overlays (start end)
2304 (let ((o-list nil)
2305 (done nil)
2306 (pos start)
2307 object pos props o)
2308 (save-excursion
2309 (save-restriction
2310 (narrow-to-region start end)
2311 (while (not done)
2312 (setq object (get-text-property pos 'vm-mime-object))
2313 (setq pos (next-single-property-change pos 'vm-mime-object))
2314 (or pos (setq pos (point-max) done t))
2315 (if object
2316 (progn
2317 (setq o (make-overlay start pos))
2318 (overlay-put o 'insert-in-front-hooks
2319 '(vm-disallow-overlay-endpoint-insertion))
2320 (overlay-put o 'insert-behind-hooks
2321 '(vm-disallow-overlay-endpoint-insertion))
2322 (setq props (text-properties-at start))
2323 (while props
2324 (overlay-put o (car props) (car (cdr props)))
2325 (setq props (cdr (cdr props))))
2326 (setq o-list (cons o o-list))))
2327 (setq start pos))
2328 o-list ))))
2050 2329
2051 (defun vm-mime-default-type-from-filename (file) 2330 (defun vm-mime-default-type-from-filename (file)
2052 (let ((alist vm-mime-attachment-auto-type-alist) 2331 (let ((alist vm-mime-attachment-auto-type-alist)
2053 (case-fold-search t) 2332 (case-fold-search t)
2054 (done nil)) 2333 (done nil))
2099 t) 2378 t)
2100 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) 2379 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
2101 (vm-mm-layout-body-start layout) 2380 (vm-mm-layout-body-start layout)
2102 (vm-mm-layout-body-end layout) 2381 (vm-mm-layout-body-end layout)
2103 nil))) 2382 nil)))
2383
2104 (defun vm-mime-encode-composition () 2384 (defun vm-mime-encode-composition ()
2105 "MIME encode the current buffer. 2385 "MIME encode the current buffer.
2106 Attachment tags added to the buffer with vm-mime-attach-file are expanded 2386 Attachment tags added to the buffer with vm-mime-attach-file are expanded
2107 and the approriate content-type and boundary markup information is added." 2387 and the approriate content-type and boundary markup information is added."
2108 (interactive) 2388 (interactive)
2114 (error "Message is already MIME encoded.")) 2394 (error "Message is already MIME encoded."))
2115 (let ((8bit nil) 2395 (let ((8bit nil)
2116 (just-one nil) 2396 (just-one nil)
2117 (boundary-positions nil) 2397 (boundary-positions nil)
2118 already-mimed layout e e-list boundary 2398 already-mimed layout e e-list boundary
2119 type encoding charset params object opoint-min) 2399 type encoding charset params description disposition object
2400 opoint-min)
2120 (mail-text) 2401 (mail-text)
2121 (setq e-list (if (fboundp 'extent-list) 2402 (setq e-list (if (fboundp 'extent-list)
2122 (extent-list nil (point) (point-max)) 2403 (extent-list nil (point) (point-max))
2123 (overlays-in (point) (point-max))) 2404 (vm-mime-fake-attachment-overlays (point) (point-max)))
2124 e-list (vm-delete (function 2405 e-list (vm-delete (function
2125 (lambda (e) 2406 (lambda (e)
2126 (vm-extent-property e 'vm-mime-object))) 2407 (vm-extent-property e 'vm-mime-object)))
2127 e-list t) 2408 e-list t)
2128 e-list (sort e-list (function 2409 e-list (sort e-list (function
2143 (if (null e-list) 2424 (if (null e-list)
2144 (progn 2425 (progn
2145 (narrow-to-region (point) (point-max)) 2426 (narrow-to-region (point) (point-max))
2146 (setq charset (vm-determine-proper-charset (point-min) 2427 (setq charset (vm-determine-proper-charset (point-min)
2147 (point-max))) 2428 (point-max)))
2429 (if (fboundp 'encode-coding-region)
2430 (encode-coding-region (point-min) (point-max)
2431 file-coding-system))
2148 (setq encoding (vm-determine-proper-content-transfer-encoding 2432 (setq encoding (vm-determine-proper-content-transfer-encoding
2149 (point-min) 2433 (point-min)
2150 (point-max)) 2434 (point-max))
2151 encoding (vm-mime-transfer-encode-region encoding 2435 encoding (vm-mime-transfer-encode-region encoding
2152 (point-min) 2436 (point-min)
2177 t)) 2461 t))
2178 (setq boundary-positions (cons (point-marker) boundary-positions)) 2462 (setq boundary-positions (cons (point-marker) boundary-positions))
2179 (insert "Content-Type: text/plain; charset=" charset "\n") 2463 (insert "Content-Type: text/plain; charset=" charset "\n")
2180 (insert "Content-Transfer-Encoding: " encoding "\n\n") 2464 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2181 (widen)) 2465 (widen))
2182 (goto-char (vm-extent-end-position e)) 2466 (goto-char (vm-extent-start-position e))
2183 (narrow-to-region (point) (point)) 2467 (narrow-to-region (point) (point))
2184 (setq object (vm-extent-property e 'vm-mime-object)) 2468 (setq object (vm-extent-property e 'vm-mime-object))
2469 ;; insert the object
2185 (cond ((bufferp object) 2470 (cond ((bufferp object)
2186 (insert-buffer-substring object)) 2471 (insert-buffer-substring object))
2187 ((stringp object) 2472 ((stringp object)
2188 (insert-file-contents-literally object))) 2473 (let ((overridding-file-coding-system 'no-conversion))
2474 (insert-file-contents-literally object))))
2475 ;; gather information about the object from the extent.
2189 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) 2476 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded))
2190 (setq layout (vm-mime-parse-entity 2477 (setq layout (vm-mime-parse-entity
2191 nil (list "text/plain" "charset=us-ascii") 2478 nil (list "text/plain" "charset=us-ascii")
2192 "7bit") 2479 "7bit")
2193 type (car (vm-mm-layout-type layout)) 2480 type (or (vm-extent-property e 'vm-mime-type)
2194 params (cdr (vm-mm-layout-type layout))) 2481 (car (vm-mm-layout-type layout)))
2482 params (or (vm-extent-property e 'vm-mime-parameters)
2483 (cdr (vm-mm-layout-qtype layout)))
2484 description (vm-extent-property e 'vm-mime-description)
2485 disposition (or (vm-extent-property e 'vm-mime-disposition)
2486 (vm-mm-layout-qdisposition layout)))
2195 (setq type (vm-extent-property e 'vm-mime-type) 2487 (setq type (vm-extent-property e 'vm-mime-type)
2196 params (vm-extent-property e 'vm-mime-parameters))) 2488 params (vm-extent-property e 'vm-mime-parameters)
2489 description (vm-extent-property e 'vm-mime-description)
2490 disposition (vm-extent-property e 'vm-mime-disposition)))
2197 (cond ((vm-mime-types-match "text" type) 2491 (cond ((vm-mime-types-match "text" type)
2198 (setq encoding 2492 (setq encoding
2199 (vm-determine-proper-content-transfer-encoding 2493 (vm-determine-proper-content-transfer-encoding
2200 (if already-mimed 2494 (if already-mimed
2201 (vm-mm-layout-body-start layout) 2495 (vm-mm-layout-body-start layout)
2260 (setq boundary-positions (cons (point-marker) boundary-positions)) 2554 (setq boundary-positions (cons (point-marker) boundary-positions))
2261 (if (not already-mimed) 2555 (if (not already-mimed)
2262 nil 2556 nil
2263 ;; trim headers 2557 ;; trim headers
2264 (vm-reorder-message-headers 2558 (vm-reorder-message-headers
2265 nil '("Content-Description:" "Content-ID:") nil) 2559 nil (nconc (list "Content-Disposition:" "Content-ID:")
2560 (if description
2561 (list "Content-Description:")
2562 nil))
2563 nil)
2266 ;; remove header/text separator 2564 ;; remove header/text separator
2267 (goto-char (1- (vm-mm-layout-body-start layout))) 2565 (goto-char (1- (vm-mm-layout-body-start layout)))
2268 (if (looking-at "\n") 2566 (if (looking-at "\n")
2269 (delete-char 1))) 2567 (delete-char 1)))
2270 (insert "Content-Type: " type) 2568 (insert "Content-Type: " type)
2271 (if params 2569 (if params
2272 (if vm-mime-avoid-folding-content-type 2570 (if vm-mime-avoid-folding-content-type
2273 (insert "; " (mapconcat 'identity params "; ") "\n") 2571 (insert "; " (mapconcat 'identity params "; ") "\n")
2274 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) 2572 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
2275 (insert "\n")) 2573 (insert "\n"))
2574 (and description
2575 (insert "Content-Description: " description "\n"))
2576 (if disposition
2577 (progn
2578 (insert "Content-Disposition: " (car disposition))
2579 (if (cdr disposition)
2580 (insert ";\n\t" (mapconcat 'identity
2581 (cdr disposition)
2582 ";\n\t")))
2583 (insert "\n")))
2276 (insert "Content-Transfer-Encoding: " encoding "\n\n")) 2584 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
2277 (goto-char (point-max)) 2585 (goto-char (point-max))
2278 (widen) 2586 (widen)
2279 (delete-region (vm-extent-start-position e) 2587 (delete-region (vm-extent-start-position e)
2280 (vm-extent-end-position e)) 2588 (vm-extent-end-position e))
2281 (vm-detach-extent e) 2589 (vm-detach-extent e)
2590 (if (looking-at "\n")
2591 (delete-char 1))
2282 (setq e-list (cdr e-list))) 2592 (setq e-list (cdr e-list)))
2283 ;; handle the remaining chunk of text after the last 2593 ;; handle the remaining chunk of text after the last
2284 ;; extent, if any. 2594 ;; extent, if any.
2285 (if (or just-one (= (point) (point-max))) 2595 (if (or just-one (= (point) (point-max)))
2286 nil 2596 nil
2287 (setq charset (vm-determine-proper-charset (point) 2597 (setq charset (vm-determine-proper-charset (point)
2288 (point-max))) 2598 (point-max)))
2599 (if (fboundp 'encode-coding-region)
2600 (encode-coding-region (point-min) (point-max)
2601 file-coding-system))
2289 (setq encoding (vm-determine-proper-content-transfer-encoding 2602 (setq encoding (vm-determine-proper-content-transfer-encoding
2290 (point) 2603 (point)
2291 (point-max)) 2604 (point-max))
2292 encoding (vm-mime-transfer-encode-region encoding 2605 encoding (vm-mime-transfer-encode-region encoding
2293 (point) 2606 (point)
2343 (if params 2656 (if params
2344 (if vm-mime-avoid-folding-content-type 2657 (if vm-mime-avoid-folding-content-type
2345 (insert "; " (mapconcat 'identity params "; ") "\n") 2658 (insert "; " (mapconcat 'identity params "; ") "\n")
2346 (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) 2659 (insert ";\n\t" (mapconcat 'identity params ";\n\t"))))
2347 (insert "\n")) 2660 (insert "\n"))
2661 (if just-one
2662 (and description
2663 (insert "Content-Description: " description "\n")))
2664 (if (and just-one disposition)
2665 (progn
2666 (insert "Content-Disposition: " (car disposition))
2667 (if (cdr disposition)
2668 (insert ";\n\t" (mapconcat 'identity
2669 (cdr disposition)
2670 ";\n\t")))
2671 (insert "\n")))
2348 (if just-one 2672 (if just-one
2349 (insert "Content-Transfer-Encoding: " encoding "\n") 2673 (insert "Content-Transfer-Encoding: " encoding "\n")
2350 (if 8bit 2674 (if 8bit
2351 (insert "Content-Transfer-Encoding: 8bit\n") 2675 (insert "Content-Transfer-Encoding: 8bit\n")
2352 (insert "Content-Transfer-Encoding: 7bit\n"))))))) 2676 (insert "Content-Transfer-Encoding: 7bit\n")))))))
2446 (setq temp-buffer (generate-new-buffer "composition preview")) 2770 (setq temp-buffer (generate-new-buffer "composition preview"))
2447 (set-buffer temp-buffer) 2771 (set-buffer temp-buffer)
2448 ;; so vm-mime-encode-composition won't complain 2772 ;; so vm-mime-encode-composition won't complain
2449 (setq major-mode 'mail-mode) 2773 (setq major-mode 'mail-mode)
2450 (vm-insert-region-from-buffer mail-buffer) 2774 (vm-insert-region-from-buffer mail-buffer)
2451 (mapcar 'vm-copy-extent e-list) 2775 (if (vm-fsfemacs-19-p)
2776 (mapcar 'vm-copy-extent e-list))
2452 (goto-char (point-min)) 2777 (goto-char (point-min))
2453 (or (vm-mail-mode-get-header-contents "From") 2778 (or (vm-mail-mode-get-header-contents "From")
2454 (insert "From: " (or user-mail-address (user-login-name)) "\n")) 2779 (insert "From: " (or user-mail-address (user-login-name)) "\n"))
2455 (or (vm-mail-mode-get-header-contents "Message-ID") 2780 (or (vm-mail-mode-get-header-contents "Message-ID")
2456 (insert "Message-ID: <fake@fake.com>\n")) 2781 (insert "Message-ID: <fake@fake.fake>\n"))
2457 (or (vm-mail-mode-get-header-contents "Date") 2782 (or (vm-mail-mode-get-header-contents "Date")
2458 (insert "Date: " 2783 (insert "Date: "
2459 (format-time-string "%a, %d %b %Y %H%M%S %Z" 2784 (format-time-string "%a, %d %b %Y %H%M%S %Z"
2460 (current-time)) 2785 (current-time))
2461 "\n")) 2786 "\n"))