Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents 8b8b7f3559a2
children
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
36 (defun vm-mm-layout-header-start (e) (aref e 7)) 36 (defun vm-mm-layout-header-start (e) (aref e 7))
37 (defun vm-mm-layout-body-start (e) (aref e 8)) 37 (defun vm-mm-layout-body-start (e) (aref e 8))
38 (defun vm-mm-layout-body-end (e) (aref e 9)) 38 (defun vm-mm-layout-body-end (e) (aref e 9))
39 (defun vm-mm-layout-parts (e) (aref e 10)) 39 (defun vm-mm-layout-parts (e) (aref e 10))
40 (defun vm-mm-layout-cache (e) (aref e 11)) 40 (defun vm-mm-layout-cache (e) (aref e 11))
41 ;; if display of MIME part fails, error string will be here.
42 (defun vm-mm-layout-display-error (e) (aref e 12))
41 43
42 (defun vm-set-mm-layout-type (e type) (aset e 0 type)) 44 (defun vm-set-mm-layout-type (e type) (aset e 0 type))
43 (defun vm-set-mm-layout-cache (e c) (aset e 11 c)) 45 (defun vm-set-mm-layout-cache (e c) (aset e 11 c))
46 (defun vm-set-mm-layout-display-error (e c) (aset e 12 c))
44 47
45 (defun vm-mm-layout (m) 48 (defun vm-mm-layout (m)
46 (or (vm-mime-layout-of m) 49 (or (vm-mime-layout-of m)
47 (progn (vm-set-mime-layout-of 50 (progn (vm-set-mime-layout-of
48 m 51 m
102 (delete-char -1) 105 (delete-char -1)
103 (insert "\r\n")))))) 106 (insert "\r\n"))))))
104 107
105 (defun vm-mime-charset-decode-region (charset start end) 108 (defun vm-mime-charset-decode-region (charset start end)
106 (or (markerp end) (setq end (vm-marker end))) 109 (or (markerp end) (setq end (vm-marker end)))
107 (cond ((vm-xemacs-mule-p) 110 (cond (vm-xemacs-mule-p
108 (if (eq (device-type) 'x) 111 (if (eq (device-type) 'x)
109 (let ((buffer-read-only nil) 112 (let ((buffer-read-only nil)
110 (cell (cdr (vm-string-assoc 113 (cell (cdr (vm-string-assoc
111 charset 114 charset
112 vm-mime-mule-charset-to-coding-alist))) 115 vm-mime-mule-charset-to-coding-alist)))
342 1 nil work-buffer) 345 1 nil work-buffer)
343 (forward-char 2)) 346 (forward-char 2))
344 ((looking-at "\n") ; soft line break 347 ((looking-at "\n") ; soft line break
345 (forward-char)) 348 (forward-char))
346 ((looking-at "\r") 349 ((looking-at "\r")
347 ;; assume the user's goatfucking 350 ;; assume the user's goatloving
348 ;; delivery software didn't convert 351 ;; delivery software didn't convert
349 ;; from Internet's CRLF newline 352 ;; from Internet's CRLF newline
350 ;; convention to the local LF 353 ;; convention to the local LF
351 ;; convention. 354 ;; convention.
352 (forward-char)) 355 (forward-char))
389 (not (= ?\n (char-after (1+ inputpos))))) 392 (not (= ?\n (char-after (1+ inputpos)))))
390 (vm-insert-char char 1 nil work-buffer) 393 (vm-insert-char char 1 nil work-buffer)
391 (vm-increment cols)) 394 (vm-increment cols))
392 ((or (< char 33) (> char 126) (= char 61) 395 ((or (< char 33) (> char 126) (= char 61)
393 (and quote-from (= cols 0) (let ((case-fold-search nil)) 396 (and quote-from (= cols 0) (let ((case-fold-search nil))
394 (looking-at "From ")))) 397 (looking-at "From ")))
398 (and (= cols 0) (= char ?.)
399 (looking-at "\\.\\(\n\\|\\'\\)")))
395 (vm-insert-char ?= 1 nil work-buffer) 400 (vm-insert-char ?= 1 nil work-buffer)
396 (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist)) 401 (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist))
397 1 nil work-buffer) 402 1 nil work-buffer)
398 (vm-insert-char (car (rassq (logand char 15) 403 (vm-insert-char (car (rassq (logand char 15)
399 hex-digit-alist)) 404 hex-digit-alist))
524 (if (and vm-display-using-mime 529 (if (and vm-display-using-mime
525 (text-property-any 0 (length string) 'vm-string t string)) 530 (text-property-any 0 (length string) 'vm-string t string))
526 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words) 531 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words)
527 string )) 532 string ))
528 533
529 (defun vm-mime-parse-content-header (string &optional sepchar keep-quotes) 534 (fset 'vm-mime-parse-content-header 'vm-parse-structured-header)
530 (if (null string)
531 ()
532 (let ((work-buffer nil))
533 (save-excursion
534 (unwind-protect
535 (let ((list nil)
536 (nonspecials "^\"\\( \t\n\r\f")
537 start s char sp+sepchar)
538 (if sepchar
539 (setq nonspecials (concat nonspecials (list sepchar))
540 sp+sepchar (concat "\t\f\n\r " (list sepchar))))
541 (setq work-buffer (generate-new-buffer "*vm-work*"))
542 (buffer-disable-undo work-buffer)
543 (set-buffer work-buffer)
544 (insert string)
545 (goto-char (point-min))
546 (skip-chars-forward "\t\f\n\r ")
547 (setq start (point))
548 (while (not (eobp))
549 (skip-chars-forward nonspecials)
550 (setq char (following-char))
551 (cond ((looking-at "[ \t\n\r\f]")
552 (delete-char 1))
553 ((= char ?\\)
554 (forward-char 1)
555 (if (not (eobp))
556 (forward-char 1)))
557 ((and sepchar (= char sepchar))
558 (setq s (buffer-substring start (point)))
559 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
560 (not (string= s "")))
561 (setq list (cons s list)))
562 (skip-chars-forward sp+sepchar)
563 (setq start (point)))
564 ((looking-at " \t\n\r\f")
565 (skip-chars-forward " \t\n\r\f"))
566 ((= char ?\")
567 (let ((done nil))
568 (if keep-quotes
569 (forward-char 1)
570 (delete-char 1))
571 (while (not done)
572 (if (null (re-search-forward "[\\\"]" nil t))
573 (setq done t)
574 (setq char (char-after (1- (point))))
575 (cond ((char-equal char ?\\)
576 (delete-char -1)
577 (if (eobp)
578 (setq done t)
579 (forward-char 1)))
580 (t (if (not keep-quotes)
581 (delete-char -1))
582 (setq done t)))))))
583 ((= char ?\()
584 (let ((done nil)
585 (pos (point))
586 (parens 1))
587 (forward-char 1)
588 (while (not done)
589 (if (null (re-search-forward "[\\()]" nil t))
590 (setq done t)
591 (setq char (char-after (1- (point))))
592 (cond ((char-equal char ?\\)
593 (if (eobp)
594 (setq done t)
595 (forward-char 1)))
596 ((char-equal char ?\()
597 (setq parens (1+ parens)))
598 (t
599 (setq parens (1- parens)
600 done (zerop parens))))))
601 (delete-region pos (point))))))
602 (setq s (buffer-substring start (point)))
603 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
604 (not (string= s "")))
605 (setq list (cons s list)))
606 (nreverse list))
607 (and work-buffer (kill-buffer work-buffer)))))))
608 535
609 (defun vm-mime-get-header-contents (header-name-regexp) 536 (defun vm-mime-get-header-contents (header-name-regexp)
610 (let ((contents nil) 537 (let ((contents nil)
611 regexp) 538 regexp)
612 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) 539 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
639 qtype (vm-mime-parse-content-header type ?\; t) 566 qtype (vm-mime-parse-content-header type ?\; t)
640 type (vm-mime-parse-content-header type ?\;) 567 type (vm-mime-parse-content-header type ?\;)
641 encoding (or (vm-get-header-contents 568 encoding (or (vm-get-header-contents
642 m "Content-Transfer-Encoding:") 569 m "Content-Transfer-Encoding:")
643 "7bit") 570 "7bit")
644 encoding (car (vm-mime-parse-content-header encoding)) 571 encoding (or (car
572 (vm-mime-parse-content-header encoding))
573 "7bit")
645 id (vm-get-header-contents m "Content-ID:") 574 id (vm-get-header-contents m "Content-ID:")
646 id (car (vm-mime-parse-content-header id)) 575 id (car (vm-mime-parse-content-header id))
647 description (vm-get-header-contents 576 description (vm-get-header-contents
648 m "Content-Description:") 577 m "Content-Description:")
649 description (and description 578 description (and description
668 type (or (vm-mime-parse-content-header type ?\;) 597 type (or (vm-mime-parse-content-header type ?\;)
669 default-type) 598 default-type)
670 encoding (or (vm-mime-get-header-contents 599 encoding (or (vm-mime-get-header-contents
671 "Content-Transfer-Encoding:") 600 "Content-Transfer-Encoding:")
672 default-encoding) 601 default-encoding)
673 encoding (car (vm-mime-parse-content-header encoding)) 602 encoding (or (car (vm-mime-parse-content-header encoding))
603 default-encoding)
674 id (vm-mime-get-header-contents "Content-ID:") 604 id (vm-mime-get-header-contents "Content-ID:")
675 id (car (vm-mime-parse-content-header id)) 605 id (car (vm-mime-parse-content-header id))
676 description (vm-mime-get-header-contents 606 description (vm-mime-get-header-contents
677 "Content-Description:") 607 "Content-Description:")
678 description (and description (if (string-match "^[ \t\n]+$" 608 description (and description (if (string-match "^[ \t\n]+$"
743 (list 673 (list
744 (save-restriction 674 (save-restriction
745 (narrow-to-region (point) (point-max)) 675 (narrow-to-region (point) (point-max))
746 (vm-mime-parse-entity-safe nil c-t 676 (vm-mime-parse-entity-safe nil c-t
747 c-t-e))) 677 c-t-e)))
748 nil ))) 678 nil nil )))
749 (t 679 (t
750 (goto-char (point-min)) 680 (goto-char (point-min))
751 (or (re-search-forward "^\n\\|\n\\'" nil t) 681 (or (re-search-forward "^\n\\|\n\\'" nil t)
752 (vm-mime-error "MIME part missing header/body separator line")) 682 (vm-mime-error "MIME part missing header/body separator line"))
753 (throw 'return-value 683 (throw 'return-value
754 (vector type qtype encoding id description 684 (vector type qtype encoding id description
755 disposition qdisposition 685 disposition qdisposition
756 (vm-marker (point-min)) 686 (vm-marker (point-min))
757 (vm-marker (point)) 687 (vm-marker (point))
758 (vm-marker (point-max)) 688 (vm-marker (point-max))
759 nil nil )))) 689 nil nil nil ))))
760 (setq p (cdr type) 690 (setq p (cdr type)
761 boundary nil) 691 boundary nil)
762 (while p 692 (while p
763 (if (string-match "^boundary=" (car p)) 693 (if (string-match "^boundary=" (car p))
764 (setq boundary (car (vm-parse (car p) "=\\(.+\\)")) 694 (setq boundary (car (vm-parse (car p) "=\\(.+\\)"))
801 disposition qdisposition 731 disposition qdisposition
802 (vm-marker (point-min)) 732 (vm-marker (point-min))
803 (vm-marker (point)) 733 (vm-marker (point))
804 (vm-marker (point-max)) 734 (vm-marker (point-max))
805 (nreverse multipart-list) 735 (nreverse multipart-list)
806 nil ))))))) 736 nil nil )))))))
807 737
808 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) 738 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e)
809 (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) 739 (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
810 ;; don't let subpart parse errors make the whole parse fail. use default 740 ;; don't let subpart parse errors make the whole parse fail. use default
811 ;; type if the parse fails. 741 ;; type if the parse fails.
832 ;; mark as an attachment to improve the chance that the user 762 ;; mark as an attachment to improve the chance that the user
833 ;; will see the description. 763 ;; will see the description.
834 '("attachment") '("attachment") 764 '("attachment") '("attachment")
835 header 765 header
836 text 766 text
837 text-end))))) 767 text-end
768 nil nil nil)))))
838 769
839 (defun vm-mime-get-xxx-parameter (layout name param-list) 770 (defun vm-mime-get-xxx-parameter (layout name param-list)
840 (let ((match-end (1+ (length name))) 771 (let ((match-end (1+ (length name)))
841 (name-regexp (concat (regexp-quote name) "=")) 772 (name-regexp (concat (regexp-quote name) "="))
842 (case-fold-search t) 773 (case-fold-search t)
898 mode-line-format vm-mode-line-format) 829 mode-line-format vm-mode-line-format)
899 ;; scroll in place messes with scroll-up and this loses 830 ;; scroll in place messes with scroll-up and this loses
900 (defvar scroll-in-place) 831 (defvar scroll-in-place)
901 (make-local-variable 'scroll-in-place) 832 (make-local-variable 'scroll-in-place)
902 (setq scroll-in-place nil) 833 (setq scroll-in-place nil)
903 (and (vm-xemacs-mule-p) 834 (and vm-xemacs-mule-p
904 (set-file-coding-system 'binary t)) 835 (set-buffer-file-coding-system 'binary t))
905 (cond ((vm-fsfemacs-19-p) 836 (cond (vm-fsfemacs-19-p
906 ;; need to do this outside the let because 837 ;; need to do this outside the let because
907 ;; loading disp-table initializes 838 ;; loading disp-table initializes
908 ;; standard-display-table. 839 ;; standard-display-table.
909 (require 'disp-table) 840 (require 'disp-table)
910 (let* ((standard-display-table 841 (let* ((standard-display-table
911 (copy-sequence standard-display-table))) 842 (copy-sequence standard-display-table)))
912 (standard-display-european t) 843 (standard-display-european t)
913 (setq buffer-display-table standard-display-table)))) 844 (setq buffer-display-table standard-display-table))))
914 (if (and vm-frame-per-folder (vm-multiple-frames-possible-p)) 845 (if (and vm-mutable-frames vm-frame-per-folder
846 (vm-multiple-frames-possible-p))
915 (vm-set-hooks-for-frame-deletion)) 847 (vm-set-hooks-for-frame-deletion))
916 (use-local-map vm-mode-map) 848 (use-local-map vm-mode-map)
917 (and (vm-toolbar-support-possible-p) vm-use-toolbar 849 (and (vm-toolbar-support-possible-p) vm-use-toolbar
918 (vm-toolbar-install-toolbar)) 850 (vm-toolbar-install-toolbar))
919 (and (vm-menu-support-possible-p) 851 (and (vm-menu-support-possible-p)
933 ;; wrong. 865 ;; wrong.
934 (vm-vheaders-of real-m) 866 (vm-vheaders-of real-m)
935 (set-buffer b) 867 (set-buffer b)
936 (widen) 868 (widen)
937 (let ((buffer-read-only nil) 869 (let ((buffer-read-only nil)
870 ;; disable read-only text properties
871 (inhibit-read-only t)
938 (modified (buffer-modified-p))) 872 (modified (buffer-modified-p)))
939 (unwind-protect 873 (unwind-protect
940 (progn 874 (progn
941 (erase-buffer) 875 (erase-buffer)
942 (insert-buffer-substring (vm-buffer-of real-m) 876 (insert-buffer-substring (vm-buffer-of real-m)
964 (setcar vm-message-pointer mm))))) 898 (setcar vm-message-pointer mm)))))
965 899
966 (fset 'vm-presentation-mode 'vm-mode) 900 (fset 'vm-presentation-mode 'vm-mode)
967 (put 'vm-presentation-mode 'mode-class 'special) 901 (put 'vm-presentation-mode 'mode-class 'special)
968 902
969 (defvar file-coding-system) 903 (defvar buffer-file-coding-system)
970 904
971 (defun vm-determine-proper-charset (beg end) 905 (defun vm-determine-proper-charset (beg end)
972 (save-excursion 906 (save-excursion
973 (save-restriction 907 (save-restriction
974 (narrow-to-region beg end) 908 (narrow-to-region beg end)
975 (catch 'done 909 (catch 'done
976 (goto-char (point-min)) 910 (goto-char (point-min))
977 (if (vm-xemacs-mule-p) 911 (if vm-xemacs-mule-p
978 (let ((charsets (delq 'ascii (charsets-in-region beg end)))) 912 (let ((charsets (delq 'ascii (charsets-in-region beg end))))
979 (cond ((null charsets) 913 (cond ((null charsets)
980 "us-ascii") 914 "us-ascii")
981 ((cdr charsets) 915 ((cdr charsets)
982 (or (car (cdr 916 (or (car (cdr
983 (assoc (coding-system-name file-coding-system) 917 (assq (coding-system-name
984 vm-mime-mule-coding-to-charset-alist))) 918 buffer-file-coding-system)
919 vm-mime-mule-coding-to-charset-alist)))
985 "iso-2022-jp")) 920 "iso-2022-jp"))
986 (t 921 (t
987 (or (car (cdr 922 (or (car (cdr
988 (assoc 923 (assoc
989 (car charsets) 924 (car charsets)
1035 (defvar native-sound-only-on-console) 970 (defvar native-sound-only-on-console)
1036 971
1037 (defun vm-mime-can-display-internal (layout) 972 (defun vm-mime-can-display-internal (layout)
1038 (let ((type (car (vm-mm-layout-type layout)))) 973 (let ((type (car (vm-mm-layout-type layout))))
1039 (cond ((vm-mime-types-match "image/jpeg" type) 974 (cond ((vm-mime-types-match "image/jpeg" type)
1040 (and (vm-xemacs-p) 975 (and vm-xemacs-p
1041 (featurep 'jpeg) 976 (featurep 'jpeg)
1042 (eq (device-type) 'x))) 977 (eq (device-type) 'x)))
1043 ((vm-mime-types-match "image/gif" type) 978 ((vm-mime-types-match "image/gif" type)
1044 (and (vm-xemacs-p) 979 (and vm-xemacs-p
1045 (featurep 'gif) 980 (featurep 'gif)
1046 (eq (device-type) 'x))) 981 (eq (device-type) 'x)))
1047 ((vm-mime-types-match "image/png" type) 982 ((vm-mime-types-match "image/png" type)
1048 (and (vm-xemacs-p) 983 (and vm-xemacs-p
1049 (featurep 'png) 984 (featurep 'png)
1050 (eq (device-type) 'x))) 985 (eq (device-type) 'x)))
1051 ((vm-mime-types-match "image/tiff" type) 986 ((vm-mime-types-match "image/tiff" type)
1052 (and (vm-xemacs-p) 987 (and vm-xemacs-p
1053 (featurep 'tiff) 988 (featurep 'tiff)
1054 (eq (device-type) 'x))) 989 (eq (device-type) 'x)))
1055 ((vm-mime-types-match "audio/basic" type) 990 ((vm-mime-types-match "audio/basic" type)
1056 (and (vm-xemacs-p) 991 (and vm-xemacs-p
1057 (or (featurep 'native-sound) 992 (or (featurep 'native-sound)
1058 (featurep 'nas-sound)) 993 (featurep 'nas-sound))
1059 (or (device-sound-enabled-p) 994 (or (device-sound-enabled-p)
1060 (and (featurep 'native-sound) 995 (and (featurep 'native-sound)
1061 (not native-sound-only-on-console) 996 (not native-sound-only-on-console)
1066 ((or (vm-mime-types-match "text/plain" type) 1001 ((or (vm-mime-types-match "text/plain" type)
1067 (vm-mime-types-match "text/enriched" type)) 1002 (vm-mime-types-match "text/enriched" type))
1068 (let ((charset (or (vm-mime-get-parameter layout "charset") 1003 (let ((charset (or (vm-mime-get-parameter layout "charset")
1069 "us-ascii"))) 1004 "us-ascii")))
1070 (vm-mime-charset-internally-displayable-p charset))) 1005 (vm-mime-charset-internally-displayable-p charset)))
1071 ;; commented out until w3-region behavior gets worked out 1006 ((vm-mime-types-match "text/html" type)
1072 ;; 1007 (condition-case ()
1073 ;; ((vm-mime-types-match "text/html" type) 1008 (progn (require 'w3)
1074 ;; (condition-case () 1009 (fboundp 'w3-region))
1075 ;; (progn (require 'w3) 1010 (error nil)))
1076 ;; (fboundp 'w3-region))
1077 ;; (error nil)))
1078 (t nil)))) 1011 (t nil))))
1079 1012
1080 (defun vm-mime-can-convert (type) 1013 (defun vm-mime-can-convert (type)
1081 (let ((alist vm-mime-type-converter-alist) 1014 (let ((alist vm-mime-type-converter-alist)
1082 ;; fake layout. make it the wrong length so an error will 1015 ;; fake layout. make it the wrong length so an error will
1124 (vm-mm-layout-qdisposition layout) 1057 (vm-mm-layout-qdisposition layout)
1125 (vm-marker (point-min)) 1058 (vm-marker (point-min))
1126 (vm-marker (point)) 1059 (vm-marker (point))
1127 (vm-marker (point-max)) 1060 (vm-marker (point-max))
1128 nil 1061 nil
1129 nil )))) 1062 nil
1063 nil))))
1130 1064
1131 (defun vm-mime-should-display-button (layout dont-honor-content-disposition) 1065 (defun vm-mime-should-display-button (layout dont-honor-content-disposition)
1132 (if (and vm-honor-mime-content-disposition 1066 (if (and vm-honor-mime-content-disposition
1133 (not dont-honor-content-disposition) 1067 (not dont-honor-content-disposition)
1134 (vm-mm-layout-disposition layout)) 1068 (vm-mm-layout-disposition layout))
1325 (vm-mime-types-match "text" type)) 1259 (vm-mime-types-match "text" type))
1326 ;; display unmatched message and text types as 1260 ;; display unmatched message and text types as
1327 ;; text/plain. 1261 ;; text/plain.
1328 (vm-mime-display-internal-text/plain layout))) 1262 (vm-mime-display-internal-text/plain layout)))
1329 (t (and extent (vm-mime-rewrite-failed-button 1263 (t (and extent (vm-mime-rewrite-failed-button
1330 extent (vm-mm-layout-cache layout))) 1264 extent
1265 (or (vm-mm-layout-display-error layout)
1266 "no external viewer defined for type")))
1331 (vm-mime-display-internal-application/octet-stream 1267 (vm-mime-display-internal-application/octet-stream
1332 (or extent layout)))) 1268 (or extent layout))))
1333 (and extent (vm-mime-delete-button-maybe extent))) 1269 (and extent (vm-mime-delete-button-maybe extent)))
1334 (set-buffer-modified-p modified))) 1270 (set-buffer-modified-p modified)))
1335 t ) 1271 t )
1336 1272
1337 (defun vm-mime-display-button-text (layout) 1273 (defun vm-mime-display-button-text (layout)
1338 (vm-mime-display-button-xxxx layout t)) 1274 (vm-mime-display-button-xxxx layout t))
1339 1275
1340 ;; commented out until w3-region behavior is worked out 1276 (defun vm-mime-display-internal-text/html (layout)
1341 ;; 1277 (if (fboundp 'w3-region)
1342 ;;(defun vm-mime-display-internal-text/html (layout) 1278 (let ((buffer-read-only nil)
1343 ;; (let ((buffer-read-only nil) 1279 (work-buffer nil))
1344 ;; (work-buffer nil)) 1280 (message "Inlining text/html, be patient...")
1345 ;; (message "Inlining text/html, be patient...") 1281 ;; w3-region is not as tame as we would like.
1346 ;; ;; w3-region is not as tame as we would like. 1282 ;; make sure the yoke is firmly attached.
1347 ;; ;; make sure the yoke is firmly attached. 1283 (unwind-protect
1348 ;; (unwind-protect 1284 (progn
1349 ;; (progn 1285 (save-excursion
1350 ;; (save-excursion 1286 (set-buffer (setq work-buffer
1351 ;; (set-buffer (setq work-buffer 1287 (generate-new-buffer " *workbuf*")))
1352 ;; (generate-new-buffer " *workbuf*"))) 1288 (vm-mime-insert-mime-body layout)
1353 ;; (vm-mime-insert-mime-body layout) 1289 (vm-mime-transfer-decode-region layout (point-min) (point-max))
1354 ;; (vm-mime-transfer-decode-region layout (point-min) (point-max)) 1290 (save-excursion
1355 ;; (save-excursion 1291 (save-window-excursion
1356 ;; (save-window-excursion 1292 (w3-region (point-min) (point-max)))))
1357 ;; (w3-region (point-min) (point-max))))) 1293 (insert-buffer-substring work-buffer))
1358 ;; (insert-buffer-substring work-buffer)) 1294 (and work-buffer (kill-buffer work-buffer)))
1359 ;; (and work-buffer (kill-buffer work-buffer))) 1295 (message "Inlining text/html... done")
1360 ;; (message "Inlining text/html... done") 1296 t )
1361 ;; t )) 1297 (vm-set-mm-layout-display-error layout "Need W3 to inline HTML")
1298 nil ))
1362 1299
1363 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) 1300 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting)
1364 (let ((start (point)) end old-size 1301 (let ((start (point)) end old-size
1365 (buffer-read-only nil) 1302 (buffer-read-only nil)
1366 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) 1303 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
1367 (if (not (vm-mime-charset-internally-displayable-p charset)) 1304 (if (not (vm-mime-charset-internally-displayable-p charset))
1368 (progn 1305 (progn
1369 (vm-set-mm-layout-cache 1306 (vm-set-mm-layout-display-error
1370 layout (concat "Undisplayable charset: " charset)) 1307 layout (concat "Undisplayable charset: " charset))
1371 nil) 1308 nil)
1372 (vm-mime-insert-mime-body layout) 1309 (vm-mime-insert-mime-body layout)
1373 (setq end (point-marker)) 1310 (setq end (point-marker))
1374 (vm-mime-transfer-decode-region layout start end) 1311 (vm-mime-transfer-decode-region layout start end)
1401 t )) 1338 t ))
1402 1339
1403 (defun vm-mime-display-external-generic (layout) 1340 (defun vm-mime-display-external-generic (layout)
1404 (let ((program-list (vm-mime-find-external-viewer 1341 (let ((program-list (vm-mime-find-external-viewer
1405 (car (vm-mm-layout-type layout)))) 1342 (car (vm-mm-layout-type layout))))
1406 (process (nth 0 (vm-mm-layout-cache layout)))
1407 (tempfile (nth 1 (vm-mm-layout-cache layout)))
1408 (buffer-read-only nil) 1343 (buffer-read-only nil)
1409 (start (point)) 1344 (start (point))
1410 end) 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))
1411 (if (and (processp process) (eq (process-status process) 'run)) 1350 (if (and (processp process) (eq (process-status process) 'run))
1412 t 1351 t
1413 (cond ((or (null tempfile) (null (file-exists-p tempfile))) 1352 (cond ((or (null tempfile) (null (file-exists-p tempfile)))
1414 (vm-mime-insert-mime-body layout) 1353 (vm-mime-insert-mime-body layout)
1415 (setq end (point-marker)) 1354 (setq end (point-marker))
1416 (vm-mime-transfer-decode-region layout start end) 1355 (vm-mime-transfer-decode-region layout start end)
1417 (setq tempfile (vm-make-tempfile-name)) 1356 (setq tempfile (vm-make-tempfile-name))
1418 (let ((buffer-file-type buffer-file-type) 1357 (let ((buffer-file-type buffer-file-type)
1419 file-coding-system) 1358 buffer-file-coding-system)
1420 ;; Tell DOS/Windows NT whether the file is binary 1359 ;; Tell DOS/Windows NT whether the file is binary
1421 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1360 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1422 ;; Tell XEmacs/MULE not to mess with the bits unless 1361 ;; Tell XEmacs/MULE not to mess with the bits unless
1423 ;; this is a text type. 1362 ;; this is a text type.
1424 (if (vm-xemacs-mule-p) 1363 (if vm-xemacs-mule-p
1425 (if (vm-mime-text-type-p layout) 1364 (if (vm-mime-text-type-p layout)
1426 (set-file-coding-system 'no-conversion nil) 1365 (set-buffer-file-coding-system 'no-conversion nil)
1427 (set-file-coding-system 'binary t))) 1366 (set-buffer-file-coding-system 'binary t)))
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)
1428 (write-region start end tempfile nil 0)) 1372 (write-region start end tempfile nil 0))
1429 (delete-region start end) 1373 (delete-region start end)
1430 (save-excursion 1374 (save-excursion
1431 (vm-select-folder-buffer) 1375 (vm-select-folder-buffer)
1432 (setq vm-folder-garbage-alist 1376 (setq vm-folder-garbage-alist
1444 (save-excursion 1388 (save-excursion
1445 (vm-select-folder-buffer) 1389 (vm-select-folder-buffer)
1446 (setq vm-message-garbage-alist 1390 (setq vm-message-garbage-alist
1447 (cons (cons process 'delete-process) 1391 (cons (cons process 'delete-process)
1448 vm-message-garbage-alist))) 1392 vm-message-garbage-alist)))
1449 (vm-set-mm-layout-cache layout (list process tempfile)))) 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)))))))
1450 t ) 1398 t )
1451 1399
1452 (defun vm-mime-display-internal-application/octet-stream (layout) 1400 (defun vm-mime-display-internal-application/octet-stream (layout)
1453 (if (vectorp layout) 1401 (if (vectorp layout)
1454 (let ((buffer-read-only nil) 1402 (let ((buffer-read-only nil)
1455 (description (vm-mm-layout-description layout))) 1403 (description (vm-mm-layout-description layout)))
1456 (vm-mime-insert-button 1404 (vm-mime-insert-button
1457 (format "%-35.35s [%s to save to a file]" 1405 (format "%-35.35s [%s to save to a file]"
1458 (vm-mime-layout-description layout) 1406 (vm-mime-layout-description layout)
1459 (if (vm-mouse-support-possible-p) 1407 (if (vm-mouse-support-possible-here-p)
1460 "Click mouse-2" 1408 "Click mouse-2"
1461 "Press RETURN")) 1409 "Press RETURN"))
1462 (function 1410 (function
1463 (lambda (layout) 1411 (lambda (layout)
1464 (save-excursion 1412 (save-excursion
1473 (if (vm-mime-get-disposition-parameter layout "filename") 1421 (if (vm-mime-get-disposition-parameter layout "filename")
1474 nil 1422 nil
1475 (vm-mime-get-parameter layout "name")))) 1423 (vm-mime-get-parameter layout "name"))))
1476 (vm-mime-send-body-to-file layout default-filename))) 1424 (vm-mime-send-body-to-file layout default-filename)))
1477 t ) 1425 t )
1478 (fset 'vm-mime-display-button-application 1426 (fset 'vm-mime-display-button-application/octet-stream
1479 'vm-mime-display-internal-application/octet-stream) 1427 'vm-mime-display-internal-application/octet-stream)
1428
1429 (defun vm-mime-display-button-application (layout)
1430 (vm-mime-display-button-xxxx layout nil))
1480 1431
1481 (defun vm-mime-display-button-image (layout) 1432 (defun vm-mime-display-button-image (layout)
1482 (vm-mime-display-button-xxxx layout t)) 1433 (vm-mime-display-button-xxxx layout t))
1483 1434
1484 (defun vm-mime-display-button-audio (layout) 1435 (defun vm-mime-display-button-audio (layout)
1538 1489
1539 (defun vm-mime-display-button-multipart/parallel (layout) 1490 (defun vm-mime-display-button-multipart/parallel (layout)
1540 (vm-mime-insert-button 1491 (vm-mime-insert-button
1541 (format "%-35.35s [%s to display in parallel]" 1492 (format "%-35.35s [%s to display in parallel]"
1542 (vm-mime-layout-description layout) 1493 (vm-mime-layout-description layout)
1543 (if (vm-mouse-support-possible-p) 1494 (if (vm-mouse-support-possible-here-p)
1544 "Click mouse-2" 1495 "Click mouse-2"
1545 "Press RETURN")) 1496 "Press RETURN"))
1546 (function 1497 (function
1547 (lambda (layout) 1498 (lambda (layout)
1548 (save-excursion 1499 (save-excursion
1557 (if (vectorp layout) 1508 (if (vectorp layout)
1558 (let ((buffer-read-only nil)) 1509 (let ((buffer-read-only nil))
1559 (vm-mime-insert-button 1510 (vm-mime-insert-button
1560 (format "%-35.35s [%s to display]" 1511 (format "%-35.35s [%s to display]"
1561 (vm-mime-layout-description layout) 1512 (vm-mime-layout-description layout)
1562 (if (vm-mouse-support-possible-p) 1513 (if (vm-mouse-support-possible-here-p)
1563 "Click mouse-2" 1514 "Click mouse-2"
1564 "Press RETURN")) 1515 "Press RETURN"))
1565 (function 1516 (function
1566 (lambda (layout) 1517 (lambda (layout)
1567 (save-excursion 1518 (save-excursion
1584 (list this-command) '(vm-mode startup))) 1535 (list this-command) '(vm-mode startup)))
1585 t ) 1536 t )
1586 (fset 'vm-mime-display-button-multipart/digest 1537 (fset 'vm-mime-display-button-multipart/digest
1587 'vm-mime-display-internal-multipart/digest) 1538 'vm-mime-display-internal-multipart/digest)
1588 1539
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)
1545 (if (vm-mouse-support-possible-here-p)
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
1589 (defun vm-mime-display-internal-message/rfc822 (layout) 1556 (defun vm-mime-display-internal-message/rfc822 (layout)
1590 (if (vectorp layout) 1557 (if (vectorp layout)
1591 (let ((buffer-read-only nil)) 1558 (let ((start (point))
1592 (vm-mime-insert-button 1559 (buffer-read-only nil))
1593 (format "%-35.35s [%s to display]" 1560 (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout)))
1594 (vm-mime-layout-description layout) 1561 (insert ?\n)
1595 (if (vm-mouse-support-possible-p) 1562 (save-excursion
1596 "Click mouse-2" 1563 (goto-char start)
1597 "Press RETURN")) 1564 (vm-reorder-message-headers nil vm-visible-headers
1598 (function 1565 vm-invisible-header-regexp))
1599 (lambda (layout) 1566 (save-restriction
1600 (save-excursion 1567 (narrow-to-region start (point))
1601 (vm-mime-display-internal-message/rfc822 layout)))) 1568 (vm-decode-mime-encoded-words))
1602 layout nil)) 1569 (vm-mime-display-internal-multipart/mixed layout))
1603 (goto-char (vm-extent-start-position layout)) 1570 (goto-char (vm-extent-start-position layout))
1604 (setq layout (vm-extent-property layout 'vm-mime-layout)) 1571 (setq layout (vm-extent-property layout 'vm-mime-layout))
1605 (set-buffer (generate-new-buffer 1572 (set-buffer (generate-new-buffer
1606 (format "message from %s/%s" 1573 (format "message from %s/%s"
1607 (buffer-name vm-mail-buffer) 1574 (buffer-name vm-mail-buffer)
1616 ;; temp buffer, don't offer to save it. 1583 ;; temp buffer, don't offer to save it.
1617 (setq buffer-offer-save nil) 1584 (setq buffer-offer-save nil)
1618 (vm-display (or vm-presentation-buffer (current-buffer)) t 1585 (vm-display (or vm-presentation-buffer (current-buffer)) t
1619 (list this-command) '(vm-mode startup))) 1586 (list this-command) '(vm-mode startup)))
1620 t ) 1587 t )
1621 (fset 'vm-mime-display-button-message/rfc822
1622 'vm-mime-display-internal-message/rfc822)
1623 (fset 'vm-mime-display-internal-message/news 1588 (fset 'vm-mime-display-internal-message/news
1624 'vm-mime-display-internal-message/rfc822) 1589 'vm-mime-display-internal-message/rfc822)
1625 1590
1626 (defun vm-mime-display-internal-message/partial (layout) 1591 (defun vm-mime-display-internal-message/partial (layout)
1627 (if (vectorp layout) 1592 (if (vectorp layout)
1631 (vm-mime-insert-button 1596 (vm-mime-insert-button
1632 (format "%-35.35s [%s to attempt assembly]" 1597 (format "%-35.35s [%s to attempt assembly]"
1633 (concat (vm-mime-layout-description layout) 1598 (concat (vm-mime-layout-description layout)
1634 (and number (concat ", part " number)) 1599 (and number (concat ", part " number))
1635 (and number total (concat " of " total))) 1600 (and number total (concat " of " total)))
1636 (if (vm-mouse-support-possible-p) 1601 (if (vm-mouse-support-possible-here-p)
1637 "Click mouse-2" 1602 "Click mouse-2"
1638 "Press RETURN")) 1603 "Press RETURN"))
1639 (function 1604 (function
1640 (lambda (layout) 1605 (lambda (layout)
1641 (save-excursion 1606 (save-excursion
1756 t )) 1721 t ))
1757 (fset 'vm-mime-display-button-message/partial 1722 (fset 'vm-mime-display-button-message/partial
1758 'vm-mime-display-internal-message/partial) 1723 'vm-mime-display-internal-message/partial)
1759 1724
1760 (defun vm-mime-display-internal-image-xxxx (layout feature name) 1725 (defun vm-mime-display-internal-image-xxxx (layout feature name)
1761 (if (and (vm-xemacs-p) 1726 (if (and vm-xemacs-p
1762 (featurep feature) 1727 (featurep feature)
1763 (eq (device-type) 'x)) 1728 (eq (device-type) 'x))
1764 (let ((start (point)) end tempfile g e 1729 (let ((start (point)) end tempfile g e
1765 (buffer-read-only nil)) 1730 (buffer-read-only nil))
1766 (if (vm-mm-layout-cache layout) 1731 (if (setq g (cdr (assq 'vm-mime-display-internal-image-xxxx
1767 (setq g (vm-mm-layout-cache layout)) 1732 (vm-mm-layout-cache layout))))
1733 nil
1768 (vm-mime-insert-mime-body layout) 1734 (vm-mime-insert-mime-body layout)
1769 (setq end (point-marker)) 1735 (setq end (point-marker))
1770 (vm-mime-transfer-decode-region layout start end) 1736 (vm-mime-transfer-decode-region layout start end)
1771 (setq tempfile (vm-make-tempfile-name)) 1737 (setq tempfile (vm-make-tempfile-name))
1772 ;; coding system for presentation buffer is binary 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.
1773 (write-region start end tempfile nil 0) 1745 (write-region start end tempfile nil 0)
1774 (message "Creating %s glyph..." name) 1746 (message "Creating %s glyph..." name)
1775 (setq g (make-glyph 1747 (setq g (make-glyph
1776 (list (vector feature ':file tempfile) 1748 (list
1777 (vector 'string 1749 (cons (list 'win)
1778 ':data 1750 (vector feature ':file tempfile))
1779 (format "[Unknown %s image encoding]\n" 1751 (cons (list 'win)
1780 name))))) 1752 (vector 'string
1753 ':data
1754 (format "[Unknown/Bad %s image encoding]\n"
1755 name)))
1756 (cons nil
1757 (vector 'string
1758 ':data
1759 (format "[%s image]\n" name))))))
1781 (message "") 1760 (message "")
1782 (vm-set-mm-layout-cache layout g) 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))))
1783 (save-excursion 1765 (save-excursion
1784 (vm-select-folder-buffer) 1766 (vm-select-folder-buffer)
1785 (setq vm-folder-garbage-alist 1767 (setq vm-folder-garbage-alist
1786 (cons (cons tempfile 'delete-file) 1768 (cons (cons tempfile 'delete-file)
1787 vm-folder-garbage-alist))) 1769 vm-folder-garbage-alist)))
1804 1786
1805 (defun vm-mime-display-internal-image/tiff (layout) 1787 (defun vm-mime-display-internal-image/tiff (layout)
1806 (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF")) 1788 (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF"))
1807 1789
1808 (defun vm-mime-display-internal-audio/basic (layout) 1790 (defun vm-mime-display-internal-audio/basic (layout)
1809 (if (and (vm-xemacs-p) 1791 (if (and vm-xemacs-p
1810 (or (featurep 'native-sound) 1792 (or (featurep 'native-sound)
1811 (featurep 'nas-sound)) 1793 (featurep 'nas-sound))
1812 (or (device-sound-enabled-p) 1794 (or (device-sound-enabled-p)
1813 (and (featurep 'native-sound) 1795 (and (featurep 'native-sound)
1814 (not native-sound-only-on-console) 1796 (not native-sound-only-on-console)
1815 (eq (device-type) 'x)))) 1797 (eq (device-type) 'x))))
1816 (let ((start (point)) end tempfile 1798 (let ((start (point)) end tempfile
1817 (buffer-read-only nil)) 1799 (buffer-read-only nil))
1818 (if (vm-mm-layout-cache layout) 1800 (if (setq tempfile (cdr (assq 'vm-mime-display-internal-audio/basic
1819 (setq tempfile (vm-mm-layout-cache layout)) 1801 (vm-mm-layout-cache layout))))
1802 nil
1820 (vm-mime-insert-mime-body layout) 1803 (vm-mime-insert-mime-body layout)
1821 (setq end (point-marker)) 1804 (setq end (point-marker))
1822 (vm-mime-transfer-decode-region layout start end) 1805 (vm-mime-transfer-decode-region layout start end)
1823 (setq tempfile (vm-make-tempfile-name)) 1806 (setq tempfile (vm-make-tempfile-name))
1824 ;; coding system for presentation buffer is binary 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.
1825 (write-region start end tempfile nil 0) 1814 (write-region start end tempfile nil 0)
1826 (vm-set-mm-layout-cache layout tempfile) 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))))
1827 (save-excursion 1820 (save-excursion
1828 (vm-select-folder-buffer) 1821 (vm-select-folder-buffer)
1829 (setq vm-folder-garbage-alist 1822 (setq vm-folder-garbage-alist
1830 (cons (cons tempfile 'delete-file) 1823 (cons (cons tempfile 'delete-file)
1831 vm-folder-garbage-alist))) 1824 vm-folder-garbage-alist)))
1837 nil )) 1830 nil ))
1838 1831
1839 (defun vm-mime-display-button-xxxx (layout disposable) 1832 (defun vm-mime-display-button-xxxx (layout disposable)
1840 (let ((description (vm-mime-layout-description layout))) 1833 (let ((description (vm-mime-layout-description layout)))
1841 (vm-mime-insert-button 1834 (vm-mime-insert-button
1842 (format "%-35.35s [%s to display]" 1835 (format "%-35.35s [%s to attempt display]"
1843 description 1836 description
1844 (if (vm-mouse-support-possible-p) "Click mouse-2" "Press RETURN")) 1837 (if (vm-mouse-support-possible-here-p)
1838 "Click mouse-2"
1839 "Press RETURN"))
1845 (function 1840 (function
1846 (lambda (layout) 1841 (lambda (layout)
1847 (save-excursion 1842 (save-excursion
1848 (let ((vm-auto-displayed-mime-content-types t)) 1843 (let ((vm-auto-displayed-mime-content-types t))
1849 (vm-decode-mime-layout layout t))))) 1844 (vm-decode-mime-layout layout t)))))
1854 (interactive) 1849 (interactive)
1855 ;; save excursion to keep point from moving. its motion would 1850 ;; save excursion to keep point from moving. its motion would
1856 ;; drag window point along, to a place arbitrarily far from 1851 ;; drag window point along, to a place arbitrarily far from
1857 ;; where it was when the user triggered the button. 1852 ;; where it was when the user triggered the button.
1858 (save-excursion 1853 (save-excursion
1859 (cond ((vm-fsfemacs-19-p) 1854 (cond (vm-fsfemacs-19-p
1860 (let (o-list o (found nil)) 1855 (let (o-list o (found nil))
1861 (setq o-list (overlays-at (point))) 1856 (setq o-list (overlays-at (point)))
1862 (while (and o-list (not found)) 1857 (while (and o-list (not found))
1863 (cond ((overlay-get (car o-list) 'vm-mime-layout) 1858 (cond ((overlay-get (car o-list) 'vm-mime-layout)
1864 (setq found t) 1859 (setq found t)
1865 (funcall (or function (overlay-get (car o-list) 1860 (funcall (or function (overlay-get (car o-list)
1866 'vm-mime-function)) 1861 'vm-mime-function))
1867 (car o-list)))) 1862 (car o-list))))
1868 (setq o-list (cdr o-list))))) 1863 (setq o-list (cdr o-list)))))
1869 ((vm-xemacs-p) 1864 (vm-xemacs-p
1870 (let ((e (extent-at (point) nil 'vm-mime-layout))) 1865 (let ((e (extent-at (point) nil 'vm-mime-layout)))
1871 (funcall (or function (extent-property e 'vm-mime-function)) 1866 (funcall (or function (extent-property e 'vm-mime-function))
1872 e)))))) 1867 e))))))
1873 1868
1874 ;; for the karking compiler 1869 ;; for the karking compiler
1875 (defvar vm-menu-mime-dispose-menu) 1870 (defvar vm-menu-mime-dispose-menu)
1876 1871
1877 (defun vm-mime-set-extent-glyph-for-layout (e layout) 1872 (defun vm-mime-set-extent-glyph-for-type (e type)
1878 (if (and (vm-xemacs-p) (fboundp 'make-glyph) 1873 (if (and vm-xemacs-p
1879 (eq (device-type) 'x) (> (device-bitplanes) 15)) 1874 (featurep 'xpm)
1880 (let ((type (car (vm-mm-layout-type layout))) 1875 (eq (device-type) 'x)
1881 (dir vm-image-directory) 1876 (> (device-bitplanes) 7))
1882 glyph) 1877 (let ((dir vm-image-directory)
1883 (setq glyph 1878 (colorful (> (device-bitplanes) 15))
1884 (cond ((vm-mime-types-match "text" type) 1879 (tuples
1885 (make-glyph (vector 1880 '(("text" "document-simple.xpm" "document-colorful.xpm")
1886 'xpm ':file 1881 ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm")
1887 (expand-file-name "document.xpm" dir)))) 1882 ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm")
1888 ((vm-mime-types-match "image" type) 1883 ("video" "film-simple.xpm" "film-colorful.xpm")
1889 (make-glyph (vector 1884 ("message" "message-simple.xpm" "message-colorful.xpm")
1890 'gif ':file 1885 ("application" "gear-simple.xpm" "gear-colorful.xpm")
1891 (expand-file-name "mona_stamp.gif" dir)))) 1886 ("multipart" "stuffed_box-simple.xpm"
1892 ((vm-mime-types-match "audio" type) 1887 "stuffed_box-colorful.xpm")))
1893 (make-glyph (vector 1888 glyph file sym p)
1894 'xpm ':file 1889 (setq file (catch 'done
1895 (expand-file-name "audio_stamp.xpm" dir)))) 1890 (while tuples
1896 ((vm-mime-types-match "video" type) 1891 (if (vm-mime-types-match (car (car tuples)) type)
1897 (make-glyph (vector 1892 (throw 'done (car tuples))
1898 'xpm ':file 1893 (setq tuples (cdr tuples))))
1899 (expand-file-name "film.xpm" dir)))) 1894 nil)
1900 ((vm-mime-types-match "message" type) 1895 file (and file (if colorful (nth 2 file) (nth 1 file)))
1901 (make-glyph (vector 1896 sym (and file (intern file vm-image-obarray))
1902 'xpm ':file 1897 glyph (and sym (boundp sym) (symbol-value sym))
1903 (expand-file-name "message.xpm" dir)))) 1898 glyph (or glyph
1904 ((vm-mime-types-match "application" type) 1899 (and file
1905 (make-glyph (vector 1900 (make-glyph
1906 'xpm ':file 1901 (list
1907 (expand-file-name "gear.xpm" dir)))) 1902 (vector 'xpm ':file
1908 ((vm-mime-types-match "multipart" type) 1903 (expand-file-name file dir))
1909 (make-glyph (vector 1904 [nothing])))))
1910 'xpm ':file 1905 (and sym (not (boundp sym)) (set sym glyph))
1911 (expand-file-name "stuffed_box.xpm" dir))))
1912 (t nil)))
1913 (and glyph (set-extent-begin-glyph e glyph))))) 1906 (and glyph (set-extent-begin-glyph e glyph)))))
1914 1907
1915 (defun vm-mime-insert-button (caption action layout disposable) 1908 (defun vm-mime-insert-button (caption action layout disposable)
1916 (let ((start (point)) e 1909 (let ((start (point)) e
1917 (keymap (make-sparse-keymap)) 1910 (keymap (make-sparse-keymap))
1924 (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3) 1917 (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3)
1925 (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu)) 1918 (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu))
1926 (if (not (bolp)) 1919 (if (not (bolp))
1927 (insert "\n")) 1920 (insert "\n"))
1928 (insert caption "\n") 1921 (insert caption "\n")
1929 ;; we MUST have the five arg make-overlay. overlays must 1922 ;; we must use the same interface that the vm-extent functions
1930 ;; advance when text is inserted at their start position or 1923 ;; use. if they use overlays, then we call make-overlay.
1931 ;; inline text and graphics will seep into the button 1924 (if (eq (symbol-function 'vm-make-extent) 'make-overlay)
1932 ;; overlay and then be removed when the button is removed. 1925 ;; we MUST have the five arg make-overlay. overlays must
1933 (if (fboundp 'make-overlay) 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.
1934 (setq e (make-overlay start (point) nil t nil)) 1929 (setq e (make-overlay start (point) nil t nil))
1935 (setq e (make-extent start (point))) 1930 (setq e (make-extent start (point)))
1936 (set-extent-property e 'start-open t) 1931 (set-extent-property e 'start-open t)
1937 (set-extent-property e 'end-open t)) 1932 (set-extent-property e 'end-open t))
1938 (vm-mime-set-extent-glyph-for-layout e layout) 1933 (vm-mime-set-extent-glyph-for-type e (car (vm-mm-layout-type layout)))
1939 ;; for emacs 1934 ;; for emacs
1940 (vm-set-extent-property e 'mouse-face 'highlight) 1935 (vm-set-extent-property e 'mouse-face 'highlight)
1941 (vm-set-extent-property e 'local-map keymap) 1936 (vm-set-extent-property e 'local-map keymap)
1942 ;; for xemacs 1937 ;; for xemacs
1943 (vm-set-extent-property e 'highlight t) 1938 (vm-set-extent-property e 'highlight t)
1951 1946
1952 (defun vm-mime-rewrite-failed-button (button error-string) 1947 (defun vm-mime-rewrite-failed-button (button error-string)
1953 (let* ((buffer-read-only nil) 1948 (let* ((buffer-read-only nil)
1954 (start (point))) 1949 (start (point)))
1955 (goto-char (vm-extent-start-position button)) 1950 (goto-char (vm-extent-start-position button))
1956 (insert (format "DISPLAY FAILED -- %s" error-string)) 1951 (insert (format "DISPLAY FAILED -- %s\n" error-string))
1957 (vm-set-extent-endpoints button start (vm-extent-end-position button)) 1952 (vm-set-extent-endpoints button start (vm-extent-end-position button))
1958 (delete-region (point) (vm-extent-end-position button)))) 1953 (delete-region (point) (vm-extent-end-position button))))
1959 1954
1960 (defun vm-mime-send-body-to-file (layout &optional default-filename) 1955 (defun vm-mime-send-body-to-file (layout &optional default-filename)
1961 (if (not (vectorp layout)) 1956 (if (not (vectorp layout))
1998 (set-buffer work-buffer) 1993 (set-buffer work-buffer)
1999 ;; Tell DOS/Windows NT whether the file is binary 1994 ;; Tell DOS/Windows NT whether the file is binary
2000 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1995 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
2001 ;; Tell XEmacs/MULE not to mess with the bits unless 1996 ;; Tell XEmacs/MULE not to mess with the bits unless
2002 ;; this is a text type. 1997 ;; this is a text type.
2003 (if (vm-xemacs-mule-p) 1998 (if vm-xemacs-mule-p
2004 (if (vm-mime-text-type-p layout) 1999 (if (vm-mime-text-type-p layout)
2005 (set-file-coding-system 'no-conversion nil) 2000 (set-buffer-file-coding-system 'no-conversion nil)
2006 (set-file-coding-system 'binary t))) 2001 (set-buffer-file-coding-system 'binary t)))
2007 (vm-mime-insert-mime-body layout) 2002 (vm-mime-insert-mime-body layout)
2008 (vm-mime-transfer-decode-region layout (point-min) (point-max)) 2003 (vm-mime-transfer-decode-region layout (point-min) (point-max))
2009 (or (not (file-exists-p file)) 2004 (or (not (file-exists-p file))
2010 (y-or-n-p "File exists, overwrite? ") 2005 (y-or-n-p "File exists, overwrite? ")
2011 (error "Aborted")) 2006 (error "Aborted"))
2142 (while (and p (not done)) 2137 (while (and p (not done))
2143 (if (setq result (vm-mime-layout-contains-type (car p) type)) 2138 (if (setq result (vm-mime-layout-contains-type (car p) type))
2144 (setq done t) 2139 (setq done t)
2145 (setq p (cdr p)))) 2140 (setq p (cdr p))))
2146 result ))) 2141 result )))
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 ))
2147 2160
2148 (defun vm-mime-plain-message-p (m) 2161 (defun vm-mime-plain-message-p (m)
2149 (save-match-data 2162 (save-match-data
2150 (let ((o (vm-mm-layout m)) 2163 (let ((o (vm-mm-layout m))
2151 (case-fold-search t)) 2164 (case-fold-search t))
2162 (defun vm-mime-text-type-p (layout) 2175 (defun vm-mime-text-type-p (layout)
2163 (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) 2176 (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout)))
2164 (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) 2177 (vm-mime-types-match "message" (car (vm-mm-layout-type layout)))))
2165 2178
2166 (defun vm-mime-charset-internally-displayable-p (name) 2179 (defun vm-mime-charset-internally-displayable-p (name)
2167 (cond ((and (vm-xemacs-mule-p) (eq (device-type) 'x)) 2180 (cond ((and vm-xemacs-mule-p (eq (device-type) 'x))
2168 (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)) 2181 (vm-string-assoc name vm-mime-mule-charset-to-coding-alist))
2169 ((vm-multiple-fonts-possible-p) 2182 ((vm-multiple-fonts-possible-p)
2170 (or (vm-string-member name vm-mime-default-face-charsets) 2183 (or (vm-string-member name vm-mime-default-face-charsets)
2171 (vm-string-assoc name vm-mime-charset-font-alist))) 2184 (vm-string-assoc name vm-mime-charset-font-alist)))
2172 (t 2185 (t
2197 (setq done t) 2210 (setq done t)
2198 (setq mp (cdr mp)))) 2211 (setq mp (cdr mp))))
2199 (car mp))) 2212 (car mp)))
2200 2213
2201 (defun vm-mime-make-multipart-boundary () 2214 (defun vm-mime-make-multipart-boundary ()
2202 (let ((boundary (make-string 40 ?a)) 2215 (let ((boundary (make-string 10 ?a))
2203 (i 0)) 2216 (i 0))
2204 (random t) 2217 (random t)
2205 (while (< i (length boundary)) 2218 (while (< i (length boundary))
2206 (aset boundary i (aref vm-mime-base64-alphabet 2219 (aset boundary i (aref vm-mime-base64-alphabet
2207 (% (vm-abs (lsh (random) -8)) 2220 (% (vm-abs (lsh (random) -8))
2328 (list 2341 (list
2329 (concat "filename=\"" 2342 (concat "filename=\""
2330 (file-name-nondirectory object) 2343 (file-name-nondirectory object)
2331 "\""))))) 2344 "\"")))))
2332 (setq disposition (list "unspecified"))) 2345 (setq disposition (list "unspecified")))
2333 (cond ((vm-fsfemacs-19-p) 2346 (cond (vm-fsfemacs-19-p
2334 (put-text-property start end 'front-sticky nil) 2347 (put-text-property start end 'front-sticky nil)
2335 (put-text-property start end 'rear-nonsticky t) 2348 (put-text-property start end 'rear-nonsticky t)
2336 ;; can't be intangible because menu clicking at a position needs 2349 ;; can't be intangible because menu clicking at a position needs
2337 ;; to set point inside the tag so that a command can access the 2350 ;; to set point inside the tag so that a command can access the
2338 ;; text properties there. 2351 ;; text properties there.
2343 (put-text-property start end 'vm-mime-parameters params) 2356 (put-text-property start end 'vm-mime-parameters params)
2344 (put-text-property start end 'vm-mime-description description) 2357 (put-text-property start end 'vm-mime-description description)
2345 (put-text-property start end 'vm-mime-disposition disposition) 2358 (put-text-property start end 'vm-mime-disposition disposition)
2346 (put-text-property start end 'vm-mime-encoded mimed) 2359 (put-text-property start end 'vm-mime-encoded mimed)
2347 (put-text-property start end 'vm-mime-object object)) 2360 (put-text-property start end 'vm-mime-object object))
2348 ((fboundp 'make-extent) 2361 (vm-xemacs-p
2349 (setq e (make-extent start end)) 2362 (setq e (make-extent start end))
2363 (vm-mime-set-extent-glyph-for-type e (or type "text/plain"))
2350 (set-extent-property e 'start-open t) 2364 (set-extent-property e 'start-open t)
2351 (set-extent-property e 'face vm-mime-button-face) 2365 (set-extent-property e 'face vm-mime-button-face)
2352 (vm-set-extent-property e 'duplicable t) 2366 (set-extent-property e 'duplicable t)
2353 (let ((keymap (make-sparse-keymap))) 2367 (let ((keymap (make-sparse-keymap)))
2354 (if vm-popup-menu-on-mouse-3 2368 (if vm-popup-menu-on-mouse-3
2355 (define-key keymap 'button3 2369 (define-key keymap 'button3
2356 'vm-menu-popup-content-disposition-menu)) 2370 'vm-menu-popup-content-disposition-menu))
2357 (vm-set-extent-property e 'keymap keymap) 2371 (set-extent-property e 'keymap keymap)
2358 (set-extent-property e 'balloon-help 'vm-mouse-3-help)) 2372 (set-extent-property e 'balloon-help 'vm-mouse-3-help))
2359 (vm-set-extent-property e 'vm-mime-type type) 2373 (set-extent-property e 'vm-mime-type type)
2360 (vm-set-extent-property e 'vm-mime-object object) 2374 (set-extent-property e 'vm-mime-object object)
2361 (vm-set-extent-property e 'vm-mime-parameters params) 2375 (set-extent-property e 'vm-mime-parameters params)
2362 (vm-set-extent-property e 'vm-mime-description description) 2376 (set-extent-property e 'vm-mime-description description)
2363 (vm-set-extent-property e 'vm-mime-disposition disposition) 2377 (set-extent-property e 'vm-mime-disposition disposition)
2364 (vm-set-extent-property e 'vm-mime-encoded mimed))))) 2378 (set-extent-property e 'vm-mime-encoded mimed)))))
2365 2379
2366 (defun vm-mime-attachment-disposition-at-point () 2380 (defun vm-mime-attachment-disposition-at-point ()
2367 (cond ((vm-fsfemacs-19-p) 2381 (cond (vm-fsfemacs-19-p
2368 (let ((disp (get-text-property (point) 'vm-mime-disposition))) 2382 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
2369 (intern (car disp)))) 2383 (intern (car disp))))
2370 ((vm-xemacs-p) 2384 (vm-xemacs-p
2371 (let* ((e (extent-at (point) nil 'vm-mime-disposition)) 2385 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
2372 (disp (extent-property e 'vm-mime-disposition))) 2386 (disp (extent-property e 'vm-mime-disposition)))
2373 (intern (car disp)))))) 2387 (intern (car disp))))))
2374 2388
2375 (defun vm-mime-set-attachment-disposition-at-point (sym) 2389 (defun vm-mime-set-attachment-disposition-at-point (sym)
2376 (cond ((vm-fsfemacs-19-p) 2390 (cond (vm-fsfemacs-19-p
2377 (let ((disp (get-text-property (point) 'vm-mime-disposition))) 2391 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
2378 (setcar disp (symbol-name sym)))) 2392 (setcar disp (symbol-name sym))))
2379 ((vm-xemacs-p) 2393 (vm-xemacs-p
2380 (let* ((e (extent-at (point) nil 'vm-mime-disposition)) 2394 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
2381 (disp (extent-property e 'vm-mime-disposition))) 2395 (disp (extent-property e 'vm-mime-disposition)))
2382 (setcar disp (symbol-name sym)))))) 2396 (setcar disp (symbol-name sym))))))
2383 2397
2384 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end 2398 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end
2445 (let ((case-fold-search t) 2459 (let ((case-fold-search t)
2446 (armor-from (and vm-mime-composition-armor-from-lines 2460 (armor-from (and vm-mime-composition-armor-from-lines
2447 (let ((case-fold-search nil)) 2461 (let ((case-fold-search nil))
2448 (save-excursion 2462 (save-excursion
2449 (goto-char beg) 2463 (goto-char beg)
2450 (re-search-forward "^From " nil t)))))) 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)))))
2451 (cond ((string-match "^binary$" encoding) 2469 (cond ((string-match "^binary$" encoding)
2452 (vm-mime-base64-encode-region beg end crlf) 2470 (vm-mime-base64-encode-region beg end crlf)
2453 (setq encoding "base64")) 2471 (setq encoding "base64"))
2454 ((and (not armor-from) (string-match "^7bit$" encoding)) t) 2472 ((and (not armor-from) (not armor-dot)
2473 (string-match "^7bit$" encoding)) t)
2455 ((string-match "^base64$" encoding) t) 2474 ((string-match "^base64$" encoding) t)
2456 ((string-match "^quoted-printable$" encoding) t) 2475 ((string-match "^quoted-printable$" encoding) t)
2457 ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) 2476 ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable)
2458 (vm-mime-qp-encode-region beg end nil armor-from) 2477 (vm-mime-qp-encode-region beg end nil armor-from)
2459 (setq encoding "quoted-printable")) 2478 (setq encoding "quoted-printable"))
2463 (armor-from (vm-mime-qp-encode-region beg end nil armor-from)) 2482 (armor-from (vm-mime-qp-encode-region beg end nil armor-from))
2464 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t)) 2483 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t))
2465 encoding )) 2484 encoding ))
2466 2485
2467 (defun vm-mime-transfer-encode-layout (layout) 2486 (defun vm-mime-transfer-encode-layout (layout)
2468 (if (vm-mime-text-type-p layout) 2487 (let ((list (vm-mm-layout-parts layout))
2469 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) 2488 (type (car (vm-mm-layout-type layout)))
2470 (vm-mm-layout-body-start layout) 2489 (encoding "7bit")
2471 (vm-mm-layout-body-end layout) 2490 (vm-mime-8bit-text-transfer-encoding
2472 t) 2491 vm-mime-8bit-text-transfer-encoding))
2473 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) 2492 (cond ((vm-mime-composite-type-p type)
2474 (vm-mm-layout-body-start layout) 2493 ;; MIME messages of type "message" and
2475 (vm-mm-layout-body-end layout) 2494 ;; "multipart" are required to have a non-opaque
2476 nil))) 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 ))))
2477 2534
2478 (defun vm-mime-encode-composition () 2535 (defun vm-mime-encode-composition ()
2479 "MIME encode the current buffer. 2536 "MIME encode the current mail composition buffer.
2480 Attachment tags added to the buffer with vm-mime-attach-file are expanded 2537 Attachment tags added to the buffer with vm-mime-attach-file are expanded
2481 and the approriate content-type and boundary markup information is added." 2538 and the approriate content-type and boundary markup information is added."
2482 (interactive) 2539 (interactive)
2540 (cond (vm-xemacs-mule-p
2541 (vm-mime-xemacs-encode-composition))
2542 (vm-xemacs-p
2543 (vm-mime-xemacs-encode-composition))
2544 (vm-fsfemacs-19-p
2545 (vm-mime-fsfemacs-encode-composition))
2546 (t
2547 (error "don't know how to MIME encode composition for %s"
2548 (emacs-version)))))
2549
2550 (defvar enriched-mode)
2551
2552 (defun vm-mime-xemacs-encode-composition ()
2483 (save-restriction 2553 (save-restriction
2484 (widen) 2554 (widen)
2485 (if (not (eq major-mode 'mail-mode)) 2555 (if (not (eq major-mode 'mail-mode))
2486 (error "Command must be used in a VM Mail mode buffer.")) 2556 (error "Command must be used in a VM Mail mode buffer."))
2487 (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) 2557 (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
2488 (error "Message is already MIME encoded.")) 2558 (error "Message is already MIME encoded."))
2489 (let ((8bit nil) 2559 (let ((8bit nil)
2490 (just-one nil) 2560 (just-one nil)
2491 (boundary-positions nil) 2561 (boundary-positions nil)
2562 (enriched (and (boundp 'enriched-mode) enriched-mode))
2492 already-mimed layout e e-list boundary 2563 already-mimed layout e e-list boundary
2493 type encoding charset params description disposition object 2564 type encoding charset params description disposition object
2494 opoint-min) 2565 opoint-min)
2495 (mail-text) 2566 (mail-text)
2496 (setq e-list (if (fboundp 'extent-list) 2567 (setq e-list (extent-list nil (point) (point-max))
2497 (extent-list nil (point) (point-max))
2498 (vm-mime-fake-attachment-overlays (point) (point-max)))
2499 e-list (vm-delete (function 2568 e-list (vm-delete (function
2500 (lambda (e) 2569 (lambda (e)
2501 (vm-extent-property e 'vm-mime-object))) 2570 (extent-property e 'vm-mime-object)))
2502 e-list t) 2571 e-list t)
2503 e-list (sort e-list (function 2572 e-list (sort e-list (function
2504 (lambda (e1 e2) 2573 (lambda (e1 e2)
2505 (< (vm-extent-end-position e1) 2574 (< (extent-end-position e1)
2506 (vm-extent-end-position e2)))))) 2575 (extent-end-position e2))))))
2507 ;; If there's just one attachment and no other readable 2576 ;; If there's just one attachment and no other readable
2508 ;; text in the buffer then make the message type just be 2577 ;; text in the buffer then make the message type just be
2509 ;; the attachment type rather than sending a multipart 2578 ;; the attachment type rather than sending a multipart
2510 ;; message with one attachment 2579 ;; message with one attachment
2511 (setq just-one (and (= (length e-list) 1) 2580 (setq just-one (and (= (length e-list) 1)
2512 (looking-at "[ \t\n]*") 2581 (looking-at "[ \t\n]*")
2513 (= (match-end 0) 2582 (= (match-end 0)
2514 (vm-extent-start-position (car e-list))) 2583 (extent-start-position (car e-list)))
2515 (save-excursion 2584 (save-excursion
2516 (goto-char (vm-extent-end-position (car e-list))) 2585 (goto-char (extent-end-position (car e-list)))
2517 (looking-at "[ \t\n]*\\'")))) 2586 (looking-at "[ \t\n]*\\'"))))
2518 (if (null e-list) 2587 (if (null e-list)
2519 (progn 2588 (progn
2520 (narrow-to-region (point) (point-max)) 2589 (narrow-to-region (point) (point-max))
2590 ;; support enriched-mode for text/enriched composition
2591 (if enriched
2592 (let ((enriched-initial-annotation ""))
2593 (enriched-encode (point-min) (point-max))))
2521 (setq charset (vm-determine-proper-charset (point-min) 2594 (setq charset (vm-determine-proper-charset (point-min)
2522 (point-max))) 2595 (point-max)))
2523 (if (vm-xemacs-mule-p) 2596 (if vm-xemacs-mule-p
2524 (encode-coding-region (point-min) (point-max) 2597 (encode-coding-region (point-min) (point-max)
2525 file-coding-system)) 2598 buffer-file-coding-system))
2526 (setq encoding (vm-determine-proper-content-transfer-encoding 2599 (setq encoding (vm-determine-proper-content-transfer-encoding
2527 (point-min) 2600 (point-min)
2528 (point-max)) 2601 (point-max))
2529 encoding (vm-mime-transfer-encode-region encoding 2602 encoding (vm-mime-transfer-encode-region encoding
2530 (point-min) 2603 (point-min)
2534 (vm-remove-mail-mode-header-separator) 2607 (vm-remove-mail-mode-header-separator)
2535 (goto-char (point-min)) 2608 (goto-char (point-min))
2536 (vm-reorder-message-headers 2609 (vm-reorder-message-headers
2537 nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") 2610 nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
2538 (insert "MIME-Version: 1.0\n") 2611 (insert "MIME-Version: 1.0\n")
2539 (insert "Content-Type: text/plain; charset=" charset "\n") 2612 (if enriched
2613 (insert "Content-Type: text/enriched; charset=" charset "\n")
2614 (insert "Content-Type: text/plain; charset=" charset "\n"))
2540 (insert "Content-Transfer-Encoding: " encoding "\n") 2615 (insert "Content-Transfer-Encoding: " encoding "\n")
2541 (vm-add-mail-mode-header-separator)) 2616 (vm-add-mail-mode-header-separator))
2542 (while e-list 2617 (while e-list
2543 (setq e (car e-list)) 2618 (setq e (car e-list))
2544 (if (or just-one (= (point) (vm-extent-start-position e))) 2619 (if (or just-one (= (point) (extent-start-position e)))
2545 nil 2620 nil
2546 (narrow-to-region (point) (vm-extent-start-position e)) 2621 (narrow-to-region (point) (extent-start-position e))
2622 (if enriched
2623 (let ((enriched-initial-annotation ""))
2624 (enriched-encode (point-min) (point-max))))
2547 (setq charset (vm-determine-proper-charset (point-min) 2625 (setq charset (vm-determine-proper-charset (point-min)
2548 (point-max))) 2626 (point-max)))
2627 (if vm-xemacs-mule-p
2628 (encode-coding-region (point-min) (point-max)
2629 buffer-file-coding-system))
2549 (setq encoding (vm-determine-proper-content-transfer-encoding 2630 (setq encoding (vm-determine-proper-content-transfer-encoding
2550 (point-min) 2631 (point-min)
2551 (point-max)) 2632 (point-max))
2552 encoding (vm-mime-transfer-encode-region encoding 2633 encoding (vm-mime-transfer-encode-region encoding
2553 (point-min) 2634 (point-min)
2554 (point-max) 2635 (point-max)
2555 t)) 2636 t))
2556 (setq boundary-positions (cons (point-marker) boundary-positions)) 2637 (setq boundary-positions (cons (point-marker) boundary-positions))
2557 (insert "Content-Type: text/plain; charset=" charset "\n") 2638 (if enriched
2639 (insert "Content-Type: text/enriched; charset=" charset "\n")
2640 (insert "Content-Type: text/plain; charset=" charset "\n"))
2558 (insert "Content-Transfer-Encoding: " encoding "\n\n") 2641 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2559 (widen)) 2642 (widen))
2560 (goto-char (vm-extent-start-position e)) 2643 (goto-char (extent-start-position e))
2561 (narrow-to-region (point) (point)) 2644 (narrow-to-region (point) (point))
2562 (setq object (vm-extent-property e 'vm-mime-object)) 2645 (setq object (extent-property e 'vm-mime-object))
2563 ;; insert the object 2646 ;; insert the object
2564 (cond ((bufferp object) 2647 (cond ((bufferp object)
2565 (if (vm-xemacs-p) 2648 (insert-buffer-substring object))
2566 (insert-buffer-substring object)
2567 ;; as of FSF Emacs 19.34, even with the hooks
2568 ;; we've attached to the attachment overlays,
2569 ;; text STILL can be inserted into them when
2570 ;; font-lock is enabled. Explaining why is
2571 ;; beyond the scope of this comment and I
2572 ;; don't know the answer anyway. This works
2573 ;; to prevent it.
2574 (insert-before-markers " ")
2575 (forward-char -1)
2576 (insert-buffer-substring object)
2577 (delete-char 1)))
2578 ((stringp object) 2649 ((stringp object)
2579 (let ((overridding-file-coding-system 'no-conversion)) 2650 (let ((coding-system-for-read 'no-conversion)
2580 (if (vm-xemacs-p) 2651 ;; don't let buffer-file-coding-system be changed
2581 (insert-file-contents-literally object) 2652 ;; by insert-file-contents-literally. The
2582 (insert-before-markers " ") 2653 ;; value we bind to it to here isn't important.
2583 (forward-char -1) 2654 (buffer-file-coding-system 'no-conversion))
2584 (insert-file-contents-literally object) 2655 (insert-file-contents-literally object))))
2585 (goto-char (point-max))
2586 (delete-char -1)))))
2587 ;; gather information about the object from the extent. 2656 ;; gather information about the object from the extent.
2588 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) 2657 (if (setq already-mimed (extent-property e 'vm-mime-encoded))
2589 (setq layout (vm-mime-parse-entity 2658 (setq layout (vm-mime-parse-entity
2590 nil (list "text/plain" "charset=us-ascii") 2659 nil (list "text/plain" "charset=us-ascii")
2591 "7bit") 2660 "7bit")
2592 type (or (vm-extent-property e 'vm-mime-type) 2661 type (or (extent-property e 'vm-mime-type)
2593 (car (vm-mm-layout-type layout))) 2662 (car (vm-mm-layout-type layout)))
2594 params (or (vm-extent-property e 'vm-mime-parameters) 2663 params (or (extent-property e 'vm-mime-parameters)
2595 (cdr (vm-mm-layout-qtype layout))) 2664 (cdr (vm-mm-layout-qtype layout)))
2596 description (vm-extent-property e 'vm-mime-description) 2665 description (extent-property e 'vm-mime-description)
2597 disposition 2666 disposition
2598 (if (not 2667 (if (not
2599 (equal 2668 (equal
2600 (car (vm-extent-property e 'vm-mime-disposition)) 2669 (car (extent-property e 'vm-mime-disposition))
2601 "unspecified")) 2670 "unspecified"))
2602 (vm-extent-property e 'vm-mime-disposition) 2671 (extent-property e 'vm-mime-disposition)
2603 (vm-mm-layout-qdisposition layout))) 2672 (vm-mm-layout-qdisposition layout)))
2604 (setq type (vm-extent-property e 'vm-mime-type) 2673 (setq type (extent-property e 'vm-mime-type)
2605 params (vm-extent-property e 'vm-mime-parameters) 2674 params (extent-property e 'vm-mime-parameters)
2606 description (vm-extent-property e 'vm-mime-description) 2675 description (extent-property e 'vm-mime-description)
2607 disposition 2676 disposition
2608 (if (not (equal 2677 (if (not (equal
2609 (car (vm-extent-property e 'vm-mime-disposition)) 2678 (car (extent-property e 'vm-mime-disposition))
2610 "unspecified")) 2679 "unspecified"))
2611 (vm-extent-property e 'vm-mime-disposition) 2680 (extent-property e 'vm-mime-disposition)
2612 nil))) 2681 nil)))
2613 (cond ((vm-mime-types-match "text" type) 2682 (cond ((vm-mime-types-match "text" type)
2614 (setq encoding 2683 (setq encoding
2615 (vm-determine-proper-content-transfer-encoding 2684 (vm-determine-proper-content-transfer-encoding
2616 (if already-mimed 2685 (if already-mimed
2623 (vm-mm-layout-body-start layout) 2692 (vm-mm-layout-body-start layout)
2624 (point-min)) 2693 (point-min))
2625 (point-max) 2694 (point-max)
2626 t)) 2695 t))
2627 (setq 8bit (or 8bit (equal encoding "8bit")))) 2696 (setq 8bit (or 8bit (equal encoding "8bit"))))
2628 ((or (vm-mime-types-match "message/rfc822" type) 2697 ((vm-mime-composite-type-p type)
2629 (vm-mime-types-match "message/news" type)
2630 (vm-mime-types-match "multipart" type))
2631 (setq opoint-min (point-min)) 2698 (setq opoint-min (point-min))
2632 (if (not already-mimed) 2699 (if (not already-mimed)
2633 (setq layout (vm-mime-parse-entity 2700 (setq layout (vm-mime-parse-entity
2634 nil (list "text/plain" "charset=us-ascii") 2701 nil (list "text/plain" "charset=us-ascii")
2635 "7bit"))) 2702 "7bit")))
2636 ;; MIME messages of type "message" and 2703 (setq encoding (vm-mime-transfer-encode-layout layout))
2637 ;; "multipart" are required to have a non-opaque
2638 ;; content transfer encoding. This means that
2639 ;; if the user only wants to send out 7bit data,
2640 ;; then any subpart that contains 8bit data must
2641 ;; have an opaque (qp or base64) 8->7bit
2642 ;; conversion performed on it so that the
2643 ;; enclosing entity can use an non-opqaue
2644 ;; encoding.
2645 ;;
2646 ;; message/partial requires a "7bit" encoding so
2647 ;; force 8->7 conversion in that case.
2648 (let ((vm-mime-8bit-text-transfer-encoding
2649 (if (vm-mime-types-match "message/partial" type)
2650 'quoted-printable
2651 vm-mime-8bit-text-transfer-encoding)))
2652 (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
2653 (vm-mm-layout-parts layout)))
2654 ;; now figure out a proper content trasnfer
2655 ;; encoding value for the enclosing entity.
2656 (re-search-forward "^\n" nil t)
2657 (save-restriction
2658 (narrow-to-region (point) (point-max))
2659 (setq encoding
2660 (vm-determine-proper-content-transfer-encoding
2661 (point-min)
2662 (point-max))))
2663 (setq 8bit (or 8bit (equal encoding "8bit"))) 2704 (setq 8bit (or 8bit (equal encoding "8bit")))
2664 (goto-char (point-max)) 2705 (goto-char (point-max))
2665 (widen) 2706 (widen)
2666 (narrow-to-region opoint-min (point))) 2707 (narrow-to-region opoint-min (point)))
2667 (t 2708 (t
2706 (insert "\n"))) 2747 (insert "\n")))
2707 (insert "Content-Transfer-Encoding: " encoding "\n\n")) 2748 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
2708 (goto-char (point-max)) 2749 (goto-char (point-max))
2709 (widen) 2750 (widen)
2710 (save-excursion 2751 (save-excursion
2711 (goto-char (vm-extent-start-position e)) 2752 (goto-char (extent-start-position e))
2712 (vm-assert (looking-at "\\[ATTACHMENT"))) 2753 (vm-assert (looking-at "\\[ATTACHMENT")))
2713 (delete-region (vm-extent-start-position e) 2754 (delete-region (extent-start-position e)
2714 (vm-extent-end-position e)) 2755 (extent-end-position e))
2715 (vm-detach-extent e) 2756 (detach-extent e)
2716 (if (looking-at "\n") 2757 (if (looking-at "\n")
2717 (delete-char 1)) 2758 (delete-char 1))
2718 (setq e-list (cdr e-list))) 2759 (setq e-list (cdr e-list)))
2719 ;; handle the remaining chunk of text after the last 2760 ;; handle the remaining chunk of text after the last
2720 ;; extent, if any. 2761 ;; extent, if any.
2721 (if (or just-one (= (point) (point-max))) 2762 (if (or just-one (= (point) (point-max)))
2722 nil 2763 nil
2764 (if enriched
2765 (let ((enriched-initial-annotation ""))
2766 (enriched-encode (point) (point-max))))
2723 (setq charset (vm-determine-proper-charset (point) 2767 (setq charset (vm-determine-proper-charset (point)
2724 (point-max))) 2768 (point-max)))
2725 (if (vm-xemacs-mule-p) 2769 (if vm-xemacs-mule-p
2726 (encode-coding-region (point-min) (point-max) 2770 (encode-coding-region (point) (point-max)
2727 file-coding-system)) 2771 buffer-file-coding-system))
2728 (setq encoding (vm-determine-proper-content-transfer-encoding 2772 (setq encoding (vm-determine-proper-content-transfer-encoding
2729 (point) 2773 (point)
2730 (point-max)) 2774 (point-max))
2731 encoding (vm-mime-transfer-encode-region encoding 2775 encoding (vm-mime-transfer-encode-region encoding
2732 (point) 2776 (point)
2733 (point-max) 2777 (point-max)
2734 t)) 2778 t))
2735 (setq 8bit (or 8bit (equal encoding "8bit"))) 2779 (setq 8bit (or 8bit (equal encoding "8bit")))
2736 (setq boundary-positions (cons (point-marker) boundary-positions)) 2780 (setq boundary-positions (cons (point-marker) boundary-positions))
2737 (insert "Content-Type: text/plain; charset=" charset "\n") 2781 (if enriched
2782 (insert "Content-Type: text/enriched; charset=" charset "\n")
2783 (insert "Content-Type: text/plain; charset=" charset "\n"))
2738 (insert "Content-Transfer-Encoding: " encoding "\n\n") 2784 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2739 (goto-char (point-max))) 2785 (goto-char (point-max)))
2740 (setq boundary (vm-mime-make-multipart-boundary)) 2786 (setq boundary (vm-mime-make-multipart-boundary))
2741 (mail-text) 2787 (mail-text)
2742 (while (re-search-forward (concat "^--" 2788 (while (re-search-forward (concat "^--"
2780 boundary "\"\n") 2826 boundary "\"\n")
2781 (insert "Content-Type: " type) 2827 (insert "Content-Type: " type)
2782 (if params 2828 (if params
2783 (if vm-mime-avoid-folding-content-type 2829 (if vm-mime-avoid-folding-content-type
2784 (insert "; " (mapconcat 'identity params "; ") "\n") 2830 (insert "; " (mapconcat 'identity params "; ") "\n")
2785 (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) 2831 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
2786 (insert "\n")) 2832 (insert "\n")))
2787 (if just-one 2833 (if just-one
2788 (and description 2834 (and description
2789 (insert "Content-Description: " description "\n"))) 2835 (insert "Content-Description: " description "\n")))
2790 (if (and just-one disposition) 2836 (if (and just-one disposition)
2791 (progn 2837 (progn
2792 (insert "Content-Disposition: " (car disposition)) 2838 (insert "Content-Disposition: " (car disposition))
2793 (if (cdr disposition) 2839 (if (cdr disposition)
2794 (insert ";\n\t" (mapconcat 'identity 2840 (if vm-mime-avoid-folding-content-type
2795 (cdr disposition) 2841 (insert "; " (mapconcat 'identity (cdr disposition) "; ")
2796 ";\n\t"))) 2842 "\n")
2797 (insert "\n"))) 2843 (insert ";\n\t" (mapconcat 'identity (cdr disposition)
2844 ";\n\t")))
2845 (insert "\n"))))
2846 (if just-one
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
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)
2862 (enriched (and (boundp 'enriched-mode) enriched-mode))
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))
2890 ;; support enriched-mode for text/enriched composition
2891 (if enriched
2892 (let ((enriched-initial-annotation ""))
2893 (enriched-encode (point-min) (point-max))))
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")
2909 (if enriched
2910 (insert "Content-Type: text/enriched; charset=" charset "\n")
2911 (insert "Content-Type: text/plain; charset=" charset "\n"))
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))
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
2926 ;; front-advance / rear-advance overlay
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)))))
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))
2944 (if enriched
2945 (insert "Content-Type: text/enriched; charset=" charset "\n")
2946 (insert "Content-Type: text/plain; charset=" charset "\n"))
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"))))
3012 ((vm-mime-composite-type-p type)
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")))
3018 (setq encoding (vm-mime-transfer-encode-layout layout))
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
3079 ;; support enriched-mode for text/enriched composition
3080 (if enriched
3081 (let ((enriched-initial-annotation ""))
3082 (enriched-encode (point) (point-max))))
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))
3094 (if enriched
3095 (insert "Content-Type: text/enriched; charset=" charset "\n")
3096 (insert "Content-Type: text/plain; charset=" charset "\n"))
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")
3144 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
3145 (insert "\n")))
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)
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"))))
2798 (if just-one 3159 (if just-one
2799 (insert "Content-Transfer-Encoding: " encoding "\n") 3160 (insert "Content-Transfer-Encoding: " encoding "\n")
2800 (if 8bit 3161 (if 8bit
2801 (insert "Content-Transfer-Encoding: 8bit\n") 3162 (insert "Content-Transfer-Encoding: 8bit\n")
2802 (insert "Content-Transfer-Encoding: 7bit\n"))))))) 3163 (insert "Content-Transfer-Encoding: 7bit\n")))))))
2810 (n 1) 3171 (n 1)
2811 (the-end nil) 3172 (the-end nil)
2812 b header-start header-end master-buffer start end) 3173 b header-start header-end master-buffer start end)
2813 (vm-remove-mail-mode-header-separator) 3174 (vm-remove-mail-mode-header-separator)
2814 ;; message/partial must have "7bit" content transfer 3175 ;; message/partial must have "7bit" content transfer
2815 ;; encoding, so verify that everything has been encoded for 3176 ;; encoding, so force everything to be encoded for
2816 ;; 7bit transmission. 3177 ;; 7bit transmission.
2817 (let ((vm-mime-8bit-text-transfer-encoding 3178 (let ((vm-mime-8bit-text-transfer-encoding
2818 (if (eq vm-mime-8bit-text-transfer-encoding 'send) 3179 (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
2819 'quoted-printable 3180 'quoted-printable
2820 vm-mime-8bit-text-transfer-encoding))) 3181 vm-mime-8bit-text-transfer-encoding)))
2821 (vm-mime-map-atomic-layouts 3182 (vm-mime-transfer-encode-layout
2822 'vm-mime-transfer-encode-layout 3183 (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
2823 (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") 3184 "7bit")))
2824 "7bit"))))
2825 (goto-char (point-min)) 3185 (goto-char (point-min))
2826 (setq header-start (point)) 3186 (setq header-start (point))
2827 (search-forward "\n\n") 3187 (search-forward "\n\n")
2828 (setq header-end (1- (point))) 3188 (setq header-end (1- (point)))
2829 (setq master-buffer (current-buffer)) 3189 (setq master-buffer (current-buffer))
2862 (insert mail-header-separator "\n") 3222 (insert mail-header-separator "\n")
2863 (insert-buffer-substring master-buffer start end) 3223 (insert-buffer-substring master-buffer start end)
2864 (vm-increment n) 3224 (vm-increment n)
2865 (set-buffer master-buffer) 3225 (set-buffer master-buffer)
2866 (setq start (point))) 3226 (setq start (point)))
3227 (vm-add-mail-mode-header-separator)
2867 (message "Fragmenting message... done") 3228 (message "Fragmenting message... done")
2868 (nreverse buffers)))) 3229 (nreverse buffers))))
2869 3230
2870 (defun vm-mime-preview-composition () 3231 (defun vm-mime-preview-composition ()
2871 "Show how the current composition buffer might be displayed 3232 "Show how the current composition buffer might be displayed
2876 (interactive) 3237 (interactive)
2877 (if (not (eq major-mode 'mail-mode)) 3238 (if (not (eq major-mode 'mail-mode))
2878 (error "Command must be used in a VM Mail mode buffer.")) 3239 (error "Command must be used in a VM Mail mode buffer."))
2879 (let ((temp-buffer nil) 3240 (let ((temp-buffer nil)
2880 (mail-buffer (current-buffer)) 3241 (mail-buffer (current-buffer))
3242 (enriched (and (boundp 'enriched-mode) enriched-mode))
2881 e-list) 3243 e-list)
2882 (unwind-protect 3244 (unwind-protect
2883 (progn 3245 (progn
2884 (setq temp-buffer (generate-new-buffer "composition preview")) 3246 (setq temp-buffer (generate-new-buffer "composition preview"))
2885 (set-buffer temp-buffer) 3247 (set-buffer temp-buffer)
2886 ;; so vm-mime-encode-composition won't complain 3248 ;; so vm-mime-xxxx-encode-composition won't complain
2887 (setq major-mode 'mail-mode) 3249 (setq major-mode 'mail-mode)
3250 (set (make-local-variable 'enriched-mode) enriched)
2888 (vm-insert-region-from-buffer mail-buffer) 3251 (vm-insert-region-from-buffer mail-buffer)
2889 (goto-char (point-min)) 3252 (goto-char (point-min))
2890 (or (vm-mail-mode-get-header-contents "From") 3253 (or (vm-mail-mode-get-header-contents "From")
2891 (insert "From: " (user-login-name) "\n")) 3254 (insert "From: " (user-login-name) "\n"))
2892 (or (vm-mail-mode-get-header-contents "Message-ID") 3255 (or (vm-mail-mode-get-header-contents "Message-ID")
2897 (current-time)) 3260 (current-time))
2898 "\n")) 3261 "\n"))
2899 (and vm-send-using-mime 3262 (and vm-send-using-mime
2900 (null (vm-mail-mode-get-header-contents "MIME-Version:")) 3263 (null (vm-mail-mode-get-header-contents "MIME-Version:"))
2901 (vm-mime-encode-composition)) 3264 (vm-mime-encode-composition))
3265 (vm-remove-mail-mode-header-separator)
2902 (goto-char (point-min)) 3266 (goto-char (point-min))
2903 (insert (vm-leading-message-separator 'From_)) 3267 (insert (vm-leading-message-separator 'From_))
2904 (goto-char (point-max)) 3268 (goto-char (point-max))
2905 (insert (vm-trailing-message-separator 'From_)) 3269 (insert (vm-trailing-message-separator 'From_))
2906 (set-buffer-modified-p nil) 3270 (set-buffer-modified-p nil)
2919 (vm-display (or vm-presentation-buffer (current-buffer)) t 3283 (vm-display (or vm-presentation-buffer (current-buffer)) t
2920 (list this-command) '(vm-mode startup))) 3284 (list this-command) '(vm-mode startup)))
2921 (and temp-buffer (kill-buffer temp-buffer))))) 3285 (and temp-buffer (kill-buffer temp-buffer)))))
2922 3286
2923 (defun vm-mime-composite-type-p (type) 3287 (defun vm-mime-composite-type-p (type)
2924 (or (vm-mime-types-match "message" type) 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)))
2925 (vm-mime-types-match "multipart" type))) 3291 (vm-mime-types-match "multipart" type)))
2926 3292
2927 (defun vm-mime-map-atomic-layouts (function list) 3293 ;; Unused currrently.
2928 (while list 3294 ;;
2929 (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) 3295 ;;(defun vm-mime-map-atomic-layouts (function list)
2930 (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) 3296 ;; (while list
2931 (funcall function (car list))) 3297 ;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
2932 (setq list (cdr list)))) 3298 ;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
3299 ;; (funcall function (car list)))
3300 ;; (setq list (cdr list))))