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)