Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 136:b980b6286996 r20-2b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b2
author cvs
date Mon, 13 Aug 2007 09:31:12 +0200
parents 869e1851236b
children 585fb297b004
comparison
equal deleted inserted replaced
135:4636a6841cd6 136:b980b6286996
622 encoding id description 622 encoding id description
623 disposition qdisposition 623 disposition qdisposition
624 (vm-headers-of m) 624 (vm-headers-of m)
625 (vm-text-of m) 625 (vm-text-of m)
626 (vm-text-end-of m) 626 (vm-text-end-of m)
627 nil nil nil ))) 627 nil nil )))
628 ((null type) 628 ((null type)
629 (goto-char (point-min)) 629 (goto-char (point-min))
630 (or (re-search-forward "^\n\\|\n\\'" nil t) 630 (or (re-search-forward "^\n\\|\n\\'" nil t)
631 (vm-mime-error "MIME part missing header/body separator line")) 631 (vm-mime-error "MIME part missing header/body separator line"))
632 (vector default-type default-type 632 (vector default-type default-type
633 encoding id description 633 encoding id description
634 disposition qdisposition 634 disposition qdisposition
635 (vm-marker (point-min)) 635 (vm-marker (point-min))
636 (vm-marker (point)) 636 (vm-marker (point))
637 (vm-marker (point-max)) 637 (vm-marker (point-max))
638 nil nil nil )) 638 nil nil ))
639 ((null (string-match "[^/ ]+/[^/ ]+" (car type))) 639 ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
640 (vm-mime-error "Malformed MIME content type: %s" (car type))) 640 (vm-mime-error "Malformed MIME content type: %s" (car type)))
641 ((and (string-match "^multipart/\\|^message/" (car type)) 641 ((and (string-match "^multipart/\\|^message/" (car type))
642 (null (string-match "^\\(7bit\\|8bit\\|binary\\)$" 642 (null (string-match "^\\(7bit\\|8bit\\|binary\\)$"
643 encoding))) 643 encoding)))
755 ;; mark as an attachment to improve the chance that the user 755 ;; mark as an attachment to improve the chance that the user
756 ;; will see the description. 756 ;; will see the description.
757 '("attachment") '("attachment") 757 '("attachment") '("attachment")
758 header 758 header
759 text 759 text
760 text-end))))) 760 text-end
761 nil nil)))))
761 762
762 (defun vm-mime-get-xxx-parameter (layout name param-list) 763 (defun vm-mime-get-xxx-parameter (layout name param-list)
763 (let ((match-end (1+ (length name))) 764 (let ((match-end (1+ (length name)))
764 (name-regexp (concat (regexp-quote name) "=")) 765 (name-regexp (concat (regexp-quote name) "="))
765 (case-fold-search t) 766 (case-fold-search t)
822 ;; scroll in place messes with scroll-up and this loses 823 ;; scroll in place messes with scroll-up and this loses
823 (defvar scroll-in-place) 824 (defvar scroll-in-place)
824 (make-local-variable 'scroll-in-place) 825 (make-local-variable 'scroll-in-place)
825 (setq scroll-in-place nil) 826 (setq scroll-in-place nil)
826 (and vm-xemacs-mule-p 827 (and vm-xemacs-mule-p
827 (set-buffer-file-coding-system 'no-conversion t)) 828 (set-file-coding-system 'binary t))
828 (cond (vm-fsfemacs-19-p 829 (cond (vm-fsfemacs-19-p
829 ;; need to do this outside the let because 830 ;; need to do this outside the let because
830 ;; loading disp-table initializes 831 ;; loading disp-table initializes
831 ;; standard-display-table. 832 ;; standard-display-table.
832 (require 'disp-table) 833 (require 'disp-table)
887 (setcar vm-message-pointer mm))))) 888 (setcar vm-message-pointer mm)))))
888 889
889 (fset 'vm-presentation-mode 'vm-mode) 890 (fset 'vm-presentation-mode 'vm-mode)
890 (put 'vm-presentation-mode 'mode-class 'special) 891 (put 'vm-presentation-mode 'mode-class 'special)
891 892
892 (defvar buffer-file-coding-system) 893 (defvar file-coding-system)
893 894
894 (defun vm-determine-proper-charset (beg end) 895 (defun vm-determine-proper-charset (beg end)
895 (save-excursion 896 (save-excursion
896 (save-restriction 897 (save-restriction
897 (narrow-to-region beg end) 898 (narrow-to-region beg end)
901 (let ((charsets (delq 'ascii (charsets-in-region beg end)))) 902 (let ((charsets (delq 'ascii (charsets-in-region beg end))))
902 (cond ((null charsets) 903 (cond ((null charsets)
903 "us-ascii") 904 "us-ascii")
904 ((cdr charsets) 905 ((cdr charsets)
905 (or (car (cdr 906 (or (car (cdr
906 (assq (coding-system-name 907 (assoc (coding-system-name file-coding-system)
907 buffer-file-coding-system) 908 vm-mime-mule-coding-to-charset-alist)))
908 vm-mime-mule-coding-to-charset-alist)))
909 "iso-2022-jp")) 909 "iso-2022-jp"))
910 (t 910 (t
911 (or (car (cdr 911 (or (car (cdr
912 (assoc 912 (assoc
913 (car charsets) 913 (car charsets)
1339 (vm-mime-insert-mime-body layout) 1339 (vm-mime-insert-mime-body layout)
1340 (setq end (point-marker)) 1340 (setq end (point-marker))
1341 (vm-mime-transfer-decode-region layout start end) 1341 (vm-mime-transfer-decode-region layout start end)
1342 (setq tempfile (vm-make-tempfile-name)) 1342 (setq tempfile (vm-make-tempfile-name))
1343 (let ((buffer-file-type buffer-file-type) 1343 (let ((buffer-file-type buffer-file-type)
1344 buffer-file-coding-system) 1344 file-coding-system)
1345 ;; Tell DOS/Windows NT whether the file is binary 1345 ;; Tell DOS/Windows NT whether the file is binary
1346 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1346 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1347 ;; Tell XEmacs/MULE not to mess with the bits unless 1347 ;; Tell XEmacs/MULE not to mess with the bits unless
1348 ;; this is a text type. 1348 ;; this is a text type.
1349 (if vm-xemacs-mule-p 1349 (if vm-xemacs-mule-p
1350 (if (vm-mime-text-type-p layout) 1350 (if (vm-mime-text-type-p layout)
1351 (set-buffer-file-coding-system 'no-conversion nil) 1351 (set-file-coding-system 'no-conversion nil)
1352 (set-buffer-file-coding-system 'binary t))) 1352 (set-file-coding-system 'binary t)))
1353 (write-region start end tempfile nil 0)) 1353 (write-region start end tempfile nil 0))
1354 (delete-region start end) 1354 (delete-region start end)
1355 (save-excursion 1355 (save-excursion
1356 (vm-select-folder-buffer) 1356 (vm-select-folder-buffer)
1357 (setq vm-folder-garbage-alist 1357 (setq vm-folder-garbage-alist
1829 (setq tuples (cdr tuples)))) 1829 (setq tuples (cdr tuples))))
1830 nil) 1830 nil)
1831 file (and file (if colorful (nth 2 file) (nth 1 file))) 1831 file (and file (if colorful (nth 2 file) (nth 1 file)))
1832 sym (and file (intern file vm-image-obarray)) 1832 sym (and file (intern file vm-image-obarray))
1833 glyph (and sym (boundp sym) (symbol-value sym)) 1833 glyph (and sym (boundp sym) (symbol-value sym))
1834 glyph (or glyph (not file) 1834 glyph (or glyph
1835 (make-glyph 1835 (and file
1836 (vector 'autodetect 1836 (make-glyph
1837 ':data (expand-file-name file dir))))) 1837 (vector 'autodetect
1838 ':data (expand-file-name file dir))))))
1838 (and sym (not (boundp sym)) (set sym glyph)) 1839 (and sym (not (boundp sym)) (set sym glyph))
1839 (and glyph (set-extent-begin-glyph e glyph))))) 1840 (and glyph (set-extent-begin-glyph e glyph)))))
1840 1841
1841 (defun vm-mime-insert-button (caption action layout disposable) 1842 (defun vm-mime-insert-button (caption action layout disposable)
1842 (let ((start (point)) e 1843 (let ((start (point)) e
1928 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1929 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1929 ;; Tell XEmacs/MULE not to mess with the bits unless 1930 ;; Tell XEmacs/MULE not to mess with the bits unless
1930 ;; this is a text type. 1931 ;; this is a text type.
1931 (if vm-xemacs-mule-p 1932 (if vm-xemacs-mule-p
1932 (if (vm-mime-text-type-p layout) 1933 (if (vm-mime-text-type-p layout)
1933 (set-buffer-file-coding-system 'no-conversion nil) 1934 (set-file-coding-system 'no-conversion nil)
1934 (set-buffer-file-coding-system 'binary t))) 1935 (set-file-coding-system 'binary t)))
1935 (vm-mime-insert-mime-body layout) 1936 (vm-mime-insert-mime-body layout)
1936 (vm-mime-transfer-decode-region layout (point-min) (point-max)) 1937 (vm-mime-transfer-decode-region layout (point-min) (point-max))
1937 (or (not (file-exists-p file)) 1938 (or (not (file-exists-p file))
1938 (y-or-n-p "File exists, overwrite? ") 1939 (y-or-n-p "File exists, overwrite? ")
1939 (error "Aborted")) 1940 (error "Aborted"))
2392 (armor-from (vm-mime-qp-encode-region beg end nil armor-from)) 2393 (armor-from (vm-mime-qp-encode-region beg end nil armor-from))
2393 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t)) 2394 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t))
2394 encoding )) 2395 encoding ))
2395 2396
2396 (defun vm-mime-transfer-encode-layout (layout) 2397 (defun vm-mime-transfer-encode-layout (layout)
2397 (let ((encoding 2398 (let ((list (vm-mm-layout-parts layout))
2398 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) 2399 (type (car (vm-mm-layout-type layout)))
2399 (vm-mm-layout-body-start layout) 2400 (encoding "7bit")
2400 (vm-mm-layout-body-end layout) 2401 (vm-mime-8bit-text-transfer-encoding
2401 (vm-mime-text-type-p layout)))) 2402 vm-mime-8bit-text-transfer-encoding))
2402 (save-excursion 2403 (cond ((vm-mime-composite-type-p type)
2403 (save-restriction 2404 ;; MIME messages of type "message" and
2404 (goto-char (vm-mm-layout-header-start layout)) 2405 ;; "multipart" are required to have a non-opaque
2405 (narrow-to-region (point) (vm-mm-layout-body-start layout)) 2406 ;; content transfer encoding. This means that
2406 (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:") 2407 ;; if the user only wants to send out 7bit data,
2407 (insert "Content-Transfer-Encoding: " encoding "\n"))))) 2408 ;; then any subpart that contains 8bit data must
2409 ;; have an opaque (qp or base64) 8->7bit
2410 ;; conversion performed on it so that the
2411 ;; enclosing entity can use a non-opaque
2412 ;; encoding.
2413 ;;
2414 ;; message/partial requires a "7bit" encoding so
2415 ;; force 8->7 conversion in that case.
2416 (cond ((memq vm-mime-8bit-text-transfer-encoding
2417 '(quoted-printable base64))
2418 t)
2419 ((vm-mime-types-match "message/partial" type)
2420 (setq vm-mime-8bit-text-transfer-encoding
2421 'quoted-printable)))
2422 (while list
2423 (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit")
2424 (setq encoding "8bit"))
2425 (setq list (cdr list))))
2426 (t
2427 (if (and (vm-mime-types-match "message/partial" type)
2428 (not (memq vm-mime-8bit-text-transfer-encoding
2429 '(quoted-printable base64))))
2430 (setq vm-mime-8bit-text-transfer-encoding
2431 'quoted-printable))
2432 (setq encoding
2433 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
2434 (vm-mm-layout-body-start layout)
2435 (vm-mm-layout-body-end layout)
2436 (vm-mime-text-type-p layout)))))
2437 (save-excursion
2438 (save-restriction
2439 (goto-char (vm-mm-layout-header-start layout))
2440 (narrow-to-region (point) (vm-mm-layout-body-start layout))
2441 (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
2442 (if (not (equal encoding "7bit"))
2443 (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n"))
2444 encoding ))))
2408 2445
2409 (defun vm-mime-encode-composition () 2446 (defun vm-mime-encode-composition ()
2410 "MIME encode the current mail composition buffer. 2447 "MIME encode the current mail composition buffer.
2411 Attachment tags added to the buffer with vm-mime-attach-file are expanded 2448 Attachment tags added to the buffer with vm-mime-attach-file are expanded
2412 and the approriate content-type and boundary markup information is added." 2449 and the approriate content-type and boundary markup information is added."
2499 (setq object (extent-property e 'vm-mime-object)) 2536 (setq object (extent-property e 'vm-mime-object))
2500 ;; insert the object 2537 ;; insert the object
2501 (cond ((bufferp object) 2538 (cond ((bufferp object)
2502 (insert-buffer-substring object)) 2539 (insert-buffer-substring object))
2503 ((stringp object) 2540 ((stringp object)
2504 (let ((coding-system-for-read 'no-conversion) 2541 (let ((overriding-file-coding-system 'no-conversion)
2505 ;; don't let file-coding-system be changed 2542 ;; don't let file-coding-system be changed
2506 ;; by insert-file-contents-literally. The 2543 ;; by insert-file-contents-literally. The
2507 ;; value we bind to it to here isn't important. 2544 ;; value we bind to it to here isn't important.
2508 (buffer-file-coding-system 'no-conversion)) 2545 (file-coding-system 'no-conversion))
2509 (insert-file-contents-literally object)))) 2546 (insert-file-contents-literally object))))
2510 ;; gather information about the object from the extent. 2547 ;; gather information about the object from the extent.
2511 (if (setq already-mimed (extent-property e 'vm-mime-encoded)) 2548 (if (setq already-mimed (extent-property e 'vm-mime-encoded))
2512 (setq layout (vm-mime-parse-entity 2549 (setq layout (vm-mime-parse-entity
2513 nil (list "text/plain" "charset=us-ascii") 2550 nil (list "text/plain" "charset=us-ascii")
2546 (vm-mm-layout-body-start layout) 2583 (vm-mm-layout-body-start layout)
2547 (point-min)) 2584 (point-min))
2548 (point-max) 2585 (point-max)
2549 t)) 2586 t))
2550 (setq 8bit (or 8bit (equal encoding "8bit")))) 2587 (setq 8bit (or 8bit (equal encoding "8bit"))))
2551 ((or (vm-mime-types-match "message/rfc822" type) 2588 ((vm-mime-composite-type-p type)
2552 (vm-mime-types-match "message/news" type)
2553 (vm-mime-types-match "multipart" type))
2554 (setq opoint-min (point-min)) 2589 (setq opoint-min (point-min))
2555 (if (not already-mimed) 2590 (if (not already-mimed)
2556 (setq layout (vm-mime-parse-entity 2591 (setq layout (vm-mime-parse-entity
2557 nil (list "text/plain" "charset=us-ascii") 2592 nil (list "text/plain" "charset=us-ascii")
2558 "7bit"))) 2593 "7bit")))
2559 ;; MIME messages of type "message" and 2594 (setq encoding (vm-mime-transfer-encode-layout layout))
2560 ;; "multipart" are required to have a non-opaque
2561 ;; content transfer encoding. This means that
2562 ;; if the user only wants to send out 7bit data,
2563 ;; then any subpart that contains 8bit data must
2564 ;; have an opaque (qp or base64) 8->7bit
2565 ;; conversion performed on it so that the
2566 ;; enclosing entity can use a non-opaque
2567 ;; encoding.
2568 ;;
2569 ;; message/partial requires a "7bit" encoding so
2570 ;; force 8->7 conversion in that case.
2571 (let ((vm-mime-8bit-text-transfer-encoding
2572 (if (vm-mime-types-match "message/partial" type)
2573 'quoted-printable
2574 vm-mime-8bit-text-transfer-encoding)))
2575 (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
2576 (vm-mm-layout-parts layout)))
2577 ;; now figure out a proper content transfer
2578 ;; encoding value for the enclosing entity.
2579 (re-search-forward "^\n" nil t)
2580 (save-restriction
2581 (narrow-to-region (point) (point-max))
2582 (setq encoding
2583 (vm-determine-proper-content-transfer-encoding
2584 (point-min)
2585 (point-max))))
2586 (setq 8bit (or 8bit (equal encoding "8bit"))) 2595 (setq 8bit (or 8bit (equal encoding "8bit")))
2587 (goto-char (point-max)) 2596 (goto-char (point-max))
2588 (widen) 2597 (widen)
2589 (narrow-to-region opoint-min (point))) 2598 (narrow-to-region opoint-min (point)))
2590 (t 2599 (t
2857 (vm-mm-layout-body-start layout) 2866 (vm-mm-layout-body-start layout)
2858 (point-min)) 2867 (point-min))
2859 (point-max) 2868 (point-max)
2860 t)) 2869 t))
2861 (setq 8bit (or 8bit (equal encoding "8bit")))) 2870 (setq 8bit (or 8bit (equal encoding "8bit"))))
2862 ((or (vm-mime-types-match "message/rfc822" type) 2871 ((vm-mime-composite-type-p type)
2863 (vm-mime-types-match "message/news" type)
2864 (vm-mime-types-match "multipart" type))
2865 (setq opoint-min (point-min)) 2872 (setq opoint-min (point-min))
2866 (if (not already-mimed) 2873 (if (not already-mimed)
2867 (setq layout (vm-mime-parse-entity 2874 (setq layout (vm-mime-parse-entity
2868 nil (list "text/plain" "charset=us-ascii") 2875 nil (list "text/plain" "charset=us-ascii")
2869 "7bit"))) 2876 "7bit")))
2870 ;; MIME messages of type "message" and 2877 (setq encoding (vm-mime-transfer-encode-layout layout))
2871 ;; "multipart" are required to have a non-opaque
2872 ;; content transfer encoding. This means that
2873 ;; if the user only wants to send out 7bit data,
2874 ;; then any subpart that contains 8bit data must
2875 ;; have an opaque (qp or base64) 8->7bit
2876 ;; conversion performed on it so that the
2877 ;; enclosing entity can use a non-opaque
2878 ;; encoding.
2879 ;;
2880 ;; message/partial requires a "7bit" encoding so
2881 ;; force 8->7 conversion in that case.
2882 (let ((vm-mime-8bit-text-transfer-encoding
2883 (if (vm-mime-types-match "message/partial" type)
2884 'quoted-printable
2885 vm-mime-8bit-text-transfer-encoding)))
2886 (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
2887 (vm-mm-layout-parts layout)))
2888 ;; now figure out a proper content transfer
2889 ;; encoding value for the enclosing entity.
2890 (re-search-forward "^\n" nil t)
2891 (save-restriction
2892 (narrow-to-region (point) (point-max))
2893 (setq encoding
2894 (vm-determine-proper-content-transfer-encoding
2895 (point-min)
2896 (point-max))))
2897 (setq 8bit (or 8bit (equal encoding "8bit"))) 2878 (setq 8bit (or 8bit (equal encoding "8bit")))
2898 (goto-char (point-max)) 2879 (goto-char (point-max))
2899 (widen) 2880 (widen)
2900 (narrow-to-region opoint-min (point))) 2881 (narrow-to-region opoint-min (point)))
2901 (t 2882 (t
3043 (n 1) 3024 (n 1)
3044 (the-end nil) 3025 (the-end nil)
3045 b header-start header-end master-buffer start end) 3026 b header-start header-end master-buffer start end)
3046 (vm-remove-mail-mode-header-separator) 3027 (vm-remove-mail-mode-header-separator)
3047 ;; message/partial must have "7bit" content transfer 3028 ;; message/partial must have "7bit" content transfer
3048 ;; encoding, so verify that everything has been encoded for 3029 ;; encoding, so force everything to be encoded for
3049 ;; 7bit transmission. 3030 ;; 7bit transmission.
3050 (let ((vm-mime-8bit-text-transfer-encoding 3031 (let ((vm-mime-8bit-text-transfer-encoding
3051 (if (eq vm-mime-8bit-text-transfer-encoding '8bit) 3032 (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
3052 'quoted-printable 3033 'quoted-printable
3053 vm-mime-8bit-text-transfer-encoding))) 3034 vm-mime-8bit-text-transfer-encoding)))
3054 (vm-mime-map-atomic-layouts 3035 (vm-mime-transfer-encode-layout
3055 'vm-mime-transfer-encode-layout 3036 (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
3056 (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") 3037 "7bit")))
3057 "7bit"))))
3058 (goto-char (point-min)) 3038 (goto-char (point-min))
3059 (setq header-start (point)) 3039 (setq header-start (point))
3060 (search-forward "\n\n") 3040 (search-forward "\n\n")
3061 (setq header-end (1- (point))) 3041 (setq header-end (1- (point)))
3062 (setq master-buffer (current-buffer)) 3042 (setq master-buffer (current-buffer))
3154 (vm-display (or vm-presentation-buffer (current-buffer)) t 3134 (vm-display (or vm-presentation-buffer (current-buffer)) t
3155 (list this-command) '(vm-mode startup))) 3135 (list this-command) '(vm-mode startup)))
3156 (and temp-buffer (kill-buffer temp-buffer))))) 3136 (and temp-buffer (kill-buffer temp-buffer)))))
3157 3137
3158 (defun vm-mime-composite-type-p (type) 3138 (defun vm-mime-composite-type-p (type)
3159 (or (vm-mime-types-match "message" type) 3139 (or (and (vm-mime-types-match "message" type)
3140 (not (vm-mime-types-match "message/partial" type))
3141 (not (vm-mime-types-match "message/external-body" type)))
3160 (vm-mime-types-match "multipart" type))) 3142 (vm-mime-types-match "multipart" type)))
3161 3143
3162 (defun vm-mime-map-atomic-layouts (function list) 3144 ;; Unused currrently.
3163 (while list 3145 ;;
3164 (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) 3146 ;;(defun vm-mime-map-atomic-layouts (function list)
3165 (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) 3147 ;; (while list
3166 (funcall function (car list))) 3148 ;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
3167 (setq list (cdr list)))) 3149 ;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
3150 ;; (funcall function (car list)))
3151 ;; (setq list (cdr list))))