Mercurial > hg > xemacs-beta
comparison lisp/vm/vm-mime.el @ 126:1370575f1259 xemacs-20-1p1
Import from CVS: tag xemacs-20-1p1
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:27:39 +0200 |
parents | cca96a509cfe |
children | 869e1851236b |
comparison
equal
deleted
inserted
replaced
125:8b0638b347ec | 126:1370575f1259 |
---|---|
1392 (if (vm-mime-get-disposition-parameter layout "filename") | 1392 (if (vm-mime-get-disposition-parameter layout "filename") |
1393 nil | 1393 nil |
1394 (vm-mime-get-parameter layout "name")))) | 1394 (vm-mime-get-parameter layout "name")))) |
1395 (vm-mime-send-body-to-file layout default-filename))) | 1395 (vm-mime-send-body-to-file layout default-filename))) |
1396 t ) | 1396 t ) |
1397 (fset 'vm-mime-display-button-application | 1397 (fset 'vm-mime-display-button-application/octet-stream |
1398 'vm-mime-display-internal-application/octet-stream) | 1398 'vm-mime-display-internal-application/octet-stream) |
1399 | |
1400 (defun vm-mime-display-button-application (layout) | |
1401 (vm-mime-display-button-xxxx layout nil)) | |
1399 | 1402 |
1400 (defun vm-mime-display-button-image (layout) | 1403 (defun vm-mime-display-button-image (layout) |
1401 (vm-mime-display-button-xxxx layout t)) | 1404 (vm-mime-display-button-xxxx layout t)) |
1402 | 1405 |
1403 (defun vm-mime-display-button-audio (layout) | 1406 (defun vm-mime-display-button-audio (layout) |
1795 | 1798 |
1796 ;; for the karking compiler | 1799 ;; for the karking compiler |
1797 (defvar vm-menu-mime-dispose-menu) | 1800 (defvar vm-menu-mime-dispose-menu) |
1798 | 1801 |
1799 (defun vm-mime-set-extent-glyph-for-type (e type) | 1802 (defun vm-mime-set-extent-glyph-for-type (e type) |
1800 (if (and vm-xemacs-p (fboundp 'make-glyph) | 1803 (if (and vm-xemacs-p |
1801 (eq (device-type) 'x) (> (device-bitplanes) 7)) | 1804 (featurep 'xpm) |
1805 (eq (device-type) 'x) | |
1806 (> (device-bitplanes) 7)) | |
1802 (let ((dir vm-image-directory) | 1807 (let ((dir vm-image-directory) |
1803 (colorful (> (device-bitplanes) 15)) | 1808 (colorful (> (device-bitplanes) 15)) |
1804 (tuples | 1809 (tuples |
1805 '(("text" "document-simple.xpm" "document-colorful.xpm") | 1810 '(("text" "document-simple.xpm" "document-colorful.xpm") |
1806 ("image" "mona_stamp-simple.gif" "mona_stamp-colorful.gif") | 1811 ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm") |
1807 ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm") | 1812 ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm") |
1808 ("video" "film-simple.xpm" "film-colorful.xpm") | 1813 ("video" "film-simple.xpm" "film-colorful.xpm") |
1809 ("message" "message-simple.xpm" "message-colorful.xpm") | 1814 ("message" "message-simple.xpm" "message-colorful.xpm") |
1810 ("application" "gear-simple.xpm" "gear-colorful.xpm") | 1815 ("application" "gear-simple.xpm" "gear-colorful.xpm") |
1811 ("multipart" "stuffed_box-simple.xpm" | 1816 ("multipart" "stuffed_box-simple.xpm" |
2262 (put-text-property start end 'vm-mime-disposition disposition) | 2267 (put-text-property start end 'vm-mime-disposition disposition) |
2263 (put-text-property start end 'vm-mime-encoded mimed) | 2268 (put-text-property start end 'vm-mime-encoded mimed) |
2264 (put-text-property start end 'vm-mime-object object)) | 2269 (put-text-property start end 'vm-mime-object object)) |
2265 (vm-xemacs-p | 2270 (vm-xemacs-p |
2266 (setq e (make-extent start end)) | 2271 (setq e (make-extent start end)) |
2267 (vm-mime-set-extent-glyph-for-type e type) | 2272 (vm-mime-set-extent-glyph-for-type e (or type "text/plain")) |
2268 (set-extent-property e 'start-open t) | 2273 (set-extent-property e 'start-open t) |
2269 (set-extent-property e 'face vm-mime-button-face) | 2274 (set-extent-property e 'face vm-mime-button-face) |
2270 (set-extent-property e 'duplicable t) | 2275 (set-extent-property e 'duplicable t) |
2271 (let ((keymap (make-sparse-keymap))) | 2276 (let ((keymap (make-sparse-keymap))) |
2272 (if vm-popup-menu-on-mouse-3 | 2277 (if vm-popup-menu-on-mouse-3 |
2381 (armor-from (vm-mime-qp-encode-region beg end nil armor-from)) | 2386 (armor-from (vm-mime-qp-encode-region beg end nil armor-from)) |
2382 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t)) | 2387 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t)) |
2383 encoding )) | 2388 encoding )) |
2384 | 2389 |
2385 (defun vm-mime-transfer-encode-layout (layout) | 2390 (defun vm-mime-transfer-encode-layout (layout) |
2386 (if (vm-mime-text-type-p layout) | 2391 (let ((encoding |
2387 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) | 2392 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) |
2388 (vm-mm-layout-body-start layout) | 2393 (vm-mm-layout-body-start layout) |
2389 (vm-mm-layout-body-end layout) | 2394 (vm-mm-layout-body-end layout) |
2390 t) | 2395 (vm-mime-text-type-p layout)))) |
2391 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) | 2396 (save-excursion |
2392 (vm-mm-layout-body-start layout) | 2397 (save-restriction |
2393 (vm-mm-layout-body-end layout) | 2398 (goto-char (vm-mm-layout-header-start layout)) |
2394 nil))) | 2399 (narrow-to-region (point) (vm-mm-layout-body-start layout)) |
2400 (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:") | |
2401 (insert "Content-Transfer-Encoding: " encoding "\n"))))) | |
2395 | 2402 |
2396 (defun vm-mime-encode-composition () | 2403 (defun vm-mime-encode-composition () |
2397 "MIME encode the current mail composition buffer. | 2404 "MIME encode the current mail composition buffer. |
2398 Attachment tags added to the buffer with vm-mime-attach-file are expanded | 2405 Attachment tags added to the buffer with vm-mime-attach-file are expanded |
2399 and the approriate content-type and boundary markup information is added." | 2406 and the approriate content-type and boundary markup information is added." |
2547 ;; content transfer encoding. This means that | 2554 ;; content transfer encoding. This means that |
2548 ;; if the user only wants to send out 7bit data, | 2555 ;; if the user only wants to send out 7bit data, |
2549 ;; then any subpart that contains 8bit data must | 2556 ;; then any subpart that contains 8bit data must |
2550 ;; have an opaque (qp or base64) 8->7bit | 2557 ;; have an opaque (qp or base64) 8->7bit |
2551 ;; conversion performed on it so that the | 2558 ;; conversion performed on it so that the |
2552 ;; enclosing entity can use an non-opqaue | 2559 ;; enclosing entity can use a non-opaque |
2553 ;; encoding. | 2560 ;; encoding. |
2554 ;; | 2561 ;; |
2555 ;; message/partial requires a "7bit" encoding so | 2562 ;; message/partial requires a "7bit" encoding so |
2556 ;; force 8->7 conversion in that case. | 2563 ;; force 8->7 conversion in that case. |
2557 (let ((vm-mime-8bit-text-transfer-encoding | 2564 (let ((vm-mime-8bit-text-transfer-encoding |
2689 boundary "\"\n") | 2696 boundary "\"\n") |
2690 (insert "Content-Type: " type) | 2697 (insert "Content-Type: " type) |
2691 (if params | 2698 (if params |
2692 (if vm-mime-avoid-folding-content-type | 2699 (if vm-mime-avoid-folding-content-type |
2693 (insert "; " (mapconcat 'identity params "; ") "\n") | 2700 (insert "; " (mapconcat 'identity params "; ") "\n") |
2694 (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) | 2701 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) |
2695 (insert "\n")) | 2702 (insert "\n"))) |
2696 (if just-one | 2703 (if just-one |
2697 (and description | 2704 (and description |
2698 (insert "Content-Description: " description "\n"))) | 2705 (insert "Content-Description: " description "\n"))) |
2699 (if (and just-one disposition) | 2706 (if (and just-one disposition) |
2700 (progn | 2707 (progn |
2701 (insert "Content-Disposition: " (car disposition)) | 2708 (insert "Content-Disposition: " (car disposition)) |
2702 (if (cdr disposition) | 2709 (if (cdr disposition) |
2703 (insert ";\n\t" (mapconcat 'identity | 2710 (if vm-mime-avoid-folding-content-type |
2704 (cdr disposition) | 2711 (insert "; " (mapconcat 'identity (cdr disposition) "; ") |
2705 ";\n\t"))) | 2712 "\n") |
2706 (insert "\n"))) | 2713 (insert ";\n\t" (mapconcat 'identity (cdr disposition) |
2714 ";\n\t"))) | |
2715 (insert "\n")))) | |
2707 (if just-one | 2716 (if just-one |
2708 (insert "Content-Transfer-Encoding: " encoding "\n") | 2717 (insert "Content-Transfer-Encoding: " encoding "\n") |
2709 (if 8bit | 2718 (if 8bit |
2710 (insert "Content-Transfer-Encoding: 8bit\n") | 2719 (insert "Content-Transfer-Encoding: 8bit\n") |
2711 (insert "Content-Transfer-Encoding: 7bit\n"))))))) | 2720 (insert "Content-Transfer-Encoding: 7bit\n"))))))) |
2862 ;; content transfer encoding. This means that | 2871 ;; content transfer encoding. This means that |
2863 ;; if the user only wants to send out 7bit data, | 2872 ;; if the user only wants to send out 7bit data, |
2864 ;; then any subpart that contains 8bit data must | 2873 ;; then any subpart that contains 8bit data must |
2865 ;; have an opaque (qp or base64) 8->7bit | 2874 ;; have an opaque (qp or base64) 8->7bit |
2866 ;; conversion performed on it so that the | 2875 ;; conversion performed on it so that the |
2867 ;; enclosing entity can use an non-opqaue | 2876 ;; enclosing entity can use a non-opaque |
2868 ;; encoding. | 2877 ;; encoding. |
2869 ;; | 2878 ;; |
2870 ;; message/partial requires a "7bit" encoding so | 2879 ;; message/partial requires a "7bit" encoding so |
2871 ;; force 8->7 conversion in that case. | 2880 ;; force 8->7 conversion in that case. |
2872 (let ((vm-mime-8bit-text-transfer-encoding | 2881 (let ((vm-mime-8bit-text-transfer-encoding |
3004 boundary "\"\n") | 3013 boundary "\"\n") |
3005 (insert "Content-Type: " type) | 3014 (insert "Content-Type: " type) |
3006 (if params | 3015 (if params |
3007 (if vm-mime-avoid-folding-content-type | 3016 (if vm-mime-avoid-folding-content-type |
3008 (insert "; " (mapconcat 'identity params "; ") "\n") | 3017 (insert "; " (mapconcat 'identity params "; ") "\n") |
3009 (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) | 3018 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) |
3010 (insert "\n")) | 3019 (insert "\n"))) |
3011 (if just-one | 3020 (if just-one |
3012 (and description | 3021 (and description |
3013 (insert "Content-Description: " description "\n"))) | 3022 (insert "Content-Description: " description "\n"))) |
3014 (if (and just-one disposition) | 3023 (if (and just-one disposition) |
3015 (progn | 3024 (progn |
3016 (insert "Content-Disposition: " (car disposition)) | 3025 (insert "Content-Disposition: " (car disposition)) |
3017 (if (cdr disposition) | 3026 (if (cdr disposition) |
3018 (insert ";\n\t" (mapconcat 'identity | 3027 (if vm-mime-avoid-folding-content-type |
3019 (cdr disposition) | 3028 (insert "; " (mapconcat 'identity (cdr disposition) "; ") |
3020 ";\n\t"))) | 3029 "\n") |
3021 (insert "\n"))) | 3030 (insert ";\n\t" (mapconcat 'identity (cdr disposition) |
3031 ";\n\t"))) | |
3032 (insert "\n")))) | |
3022 (if just-one | 3033 (if just-one |
3023 (insert "Content-Transfer-Encoding: " encoding "\n") | 3034 (insert "Content-Transfer-Encoding: " encoding "\n") |
3024 (if 8bit | 3035 (if 8bit |
3025 (insert "Content-Transfer-Encoding: 8bit\n") | 3036 (insert "Content-Transfer-Encoding: 8bit\n") |
3026 (insert "Content-Transfer-Encoding: 7bit\n"))))))) | 3037 (insert "Content-Transfer-Encoding: 7bit\n"))))))) |
3106 e-list) | 3117 e-list) |
3107 (unwind-protect | 3118 (unwind-protect |
3108 (progn | 3119 (progn |
3109 (setq temp-buffer (generate-new-buffer "composition preview")) | 3120 (setq temp-buffer (generate-new-buffer "composition preview")) |
3110 (set-buffer temp-buffer) | 3121 (set-buffer temp-buffer) |
3111 ;; so vm-mime-encode-composition won't complain | 3122 ;; so vm-mime-xxxx-encode-composition won't complain |
3112 (setq major-mode 'mail-mode) | 3123 (setq major-mode 'mail-mode) |
3113 (vm-insert-region-from-buffer mail-buffer) | 3124 (vm-insert-region-from-buffer mail-buffer) |
3114 (vm-remove-mail-mode-header-separator) | |
3115 (goto-char (point-min)) | 3125 (goto-char (point-min)) |
3116 (or (vm-mail-mode-get-header-contents "From") | 3126 (or (vm-mail-mode-get-header-contents "From") |
3117 (insert "From: " (user-login-name) "\n")) | 3127 (insert "From: " (user-login-name) "\n")) |
3118 (or (vm-mail-mode-get-header-contents "Message-ID") | 3128 (or (vm-mail-mode-get-header-contents "Message-ID") |
3119 (insert "Message-ID: <fake@fake.fake>\n")) | 3129 (insert "Message-ID: <fake@fake.fake>\n")) |
3123 (current-time)) | 3133 (current-time)) |
3124 "\n")) | 3134 "\n")) |
3125 (and vm-send-using-mime | 3135 (and vm-send-using-mime |
3126 (null (vm-mail-mode-get-header-contents "MIME-Version:")) | 3136 (null (vm-mail-mode-get-header-contents "MIME-Version:")) |
3127 (vm-mime-encode-composition)) | 3137 (vm-mime-encode-composition)) |
3138 (vm-remove-mail-mode-header-separator) | |
3128 (goto-char (point-min)) | 3139 (goto-char (point-min)) |
3129 (insert (vm-leading-message-separator 'From_)) | 3140 (insert (vm-leading-message-separator 'From_)) |
3130 (goto-char (point-max)) | 3141 (goto-char (point-max)) |
3131 (insert (vm-trailing-message-separator 'From_)) | 3142 (insert (vm-trailing-message-separator 'From_)) |
3132 (set-buffer-modified-p nil) | 3143 (set-buffer-modified-p nil) |