Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 146:2af401a6ecca r20-2p1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2p1
author cvs
date Mon, 13 Aug 2007 09:34:46 +0200
parents 585fb297b004
children 43dd3413c7c7
comparison
equal deleted inserted replaced
145:e13feca31ba6 146:2af401a6ecca
35 (defun vm-mm-layout-qdisposition (e) (aref e 6)) 35 (defun vm-mm-layout-qdisposition (e) (aref e 6))
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 ;; if display of MIME part fails, error string will be here. 41 ;; if display of MIME part fails, error string will be here.
41 (defun vm-mm-layout-cache (e) (aref e 11)) 42 (defun vm-mm-layout-display-error (e) (aref e 12))
42 43
43 (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))
44 (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))
45 47
46 (defun vm-mm-layout (m) 48 (defun vm-mm-layout (m)
47 (or (vm-mime-layout-of m) 49 (or (vm-mime-layout-of m)
48 (progn (vm-set-mime-layout-of 50 (progn (vm-set-mime-layout-of
49 m 51 m
622 encoding id description 624 encoding id description
623 disposition qdisposition 625 disposition qdisposition
624 (vm-headers-of m) 626 (vm-headers-of m)
625 (vm-text-of m) 627 (vm-text-of m)
626 (vm-text-end-of m) 628 (vm-text-end-of m)
627 nil nil ))) 629 nil nil nil )))
628 ((null type) 630 ((null type)
629 (goto-char (point-min)) 631 (goto-char (point-min))
630 (or (re-search-forward "^\n\\|\n\\'" nil t) 632 (or (re-search-forward "^\n\\|\n\\'" nil t)
631 (vm-mime-error "MIME part missing header/body separator line")) 633 (vm-mime-error "MIME part missing header/body separator line"))
632 (vector default-type default-type 634 (vector default-type default-type
633 encoding id description 635 encoding id description
634 disposition qdisposition 636 disposition qdisposition
635 (vm-marker (point-min)) 637 (vm-marker (point-min))
636 (vm-marker (point)) 638 (vm-marker (point))
637 (vm-marker (point-max)) 639 (vm-marker (point-max))
638 nil nil )) 640 nil nil nil ))
639 ((null (string-match "[^/ ]+/[^/ ]+" (car type))) 641 ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
640 (vm-mime-error "Malformed MIME content type: %s" (car type))) 642 (vm-mime-error "Malformed MIME content type: %s" (car type)))
641 ((and (string-match "^multipart/\\|^message/" (car type)) 643 ((and (string-match "^multipart/\\|^message/" (car type))
642 (null (string-match "^\\(7bit\\|8bit\\|binary\\)$" 644 (null (string-match "^\\(7bit\\|8bit\\|binary\\)$"
643 encoding))) 645 encoding)))
666 (list 668 (list
667 (save-restriction 669 (save-restriction
668 (narrow-to-region (point) (point-max)) 670 (narrow-to-region (point) (point-max))
669 (vm-mime-parse-entity-safe nil c-t 671 (vm-mime-parse-entity-safe nil c-t
670 c-t-e))) 672 c-t-e)))
671 nil ))) 673 nil nil )))
672 (t 674 (t
673 (goto-char (point-min)) 675 (goto-char (point-min))
674 (or (re-search-forward "^\n\\|\n\\'" nil t) 676 (or (re-search-forward "^\n\\|\n\\'" nil t)
675 (vm-mime-error "MIME part missing header/body separator line")) 677 (vm-mime-error "MIME part missing header/body separator line"))
676 (throw 'return-value 678 (throw 'return-value
677 (vector type qtype encoding id description 679 (vector type qtype encoding id description
678 disposition qdisposition 680 disposition qdisposition
679 (vm-marker (point-min)) 681 (vm-marker (point-min))
680 (vm-marker (point)) 682 (vm-marker (point))
681 (vm-marker (point-max)) 683 (vm-marker (point-max))
682 nil nil )))) 684 nil nil nil ))))
683 (setq p (cdr type) 685 (setq p (cdr type)
684 boundary nil) 686 boundary nil)
685 (while p 687 (while p
686 (if (string-match "^boundary=" (car p)) 688 (if (string-match "^boundary=" (car p))
687 (setq boundary (car (vm-parse (car p) "=\\(.+\\)")) 689 (setq boundary (car (vm-parse (car p) "=\\(.+\\)"))
724 disposition qdisposition 726 disposition qdisposition
725 (vm-marker (point-min)) 727 (vm-marker (point-min))
726 (vm-marker (point)) 728 (vm-marker (point))
727 (vm-marker (point-max)) 729 (vm-marker (point-max))
728 (nreverse multipart-list) 730 (nreverse multipart-list)
729 nil ))))))) 731 nil nil )))))))
730 732
731 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) 733 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e)
732 (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) 734 (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
733 ;; don't let subpart parse errors make the whole parse fail. use default 735 ;; don't let subpart parse errors make the whole parse fail. use default
734 ;; type if the parse fails. 736 ;; type if the parse fails.
756 ;; will see the description. 758 ;; will see the description.
757 '("attachment") '("attachment") 759 '("attachment") '("attachment")
758 header 760 header
759 text 761 text
760 text-end 762 text-end
761 nil nil))))) 763 nil nil nil)))))
762 764
763 (defun vm-mime-get-xxx-parameter (layout name param-list) 765 (defun vm-mime-get-xxx-parameter (layout name param-list)
764 (let ((match-end (1+ (length name))) 766 (let ((match-end (1+ (length name)))
765 (name-regexp (concat (regexp-quote name) "=")) 767 (name-regexp (concat (regexp-quote name) "="))
766 (case-fold-search t) 768 (case-fold-search t)
1049 (vm-mm-layout-qdisposition layout) 1051 (vm-mm-layout-qdisposition layout)
1050 (vm-marker (point-min)) 1052 (vm-marker (point-min))
1051 (vm-marker (point)) 1053 (vm-marker (point))
1052 (vm-marker (point-max)) 1054 (vm-marker (point-max))
1053 nil 1055 nil
1054 nil )))) 1056 nil
1057 nil))))
1055 1058
1056 (defun vm-mime-should-display-button (layout dont-honor-content-disposition) 1059 (defun vm-mime-should-display-button (layout dont-honor-content-disposition)
1057 (if (and vm-honor-mime-content-disposition 1060 (if (and vm-honor-mime-content-disposition
1058 (not dont-honor-content-disposition) 1061 (not dont-honor-content-disposition)
1059 (vm-mm-layout-disposition layout)) 1062 (vm-mm-layout-disposition layout))
1251 ;; display unmatched message and text types as 1254 ;; display unmatched message and text types as
1252 ;; text/plain. 1255 ;; text/plain.
1253 (vm-mime-display-internal-text/plain layout))) 1256 (vm-mime-display-internal-text/plain layout)))
1254 (t (and extent (vm-mime-rewrite-failed-button 1257 (t (and extent (vm-mime-rewrite-failed-button
1255 extent 1258 extent
1256 (or (vm-mm-layout-cache layout) 1259 (or (vm-mm-layout-display-error layout)
1257 "no external viewer defined for type"))) 1260 "no external viewer defined for type")))
1258 (vm-mime-display-internal-application/octet-stream 1261 (vm-mime-display-internal-application/octet-stream
1259 (or extent layout)))) 1262 (or extent layout))))
1260 (and extent (vm-mime-delete-button-maybe extent))) 1263 (and extent (vm-mime-delete-button-maybe extent)))
1261 (set-buffer-modified-p modified))) 1264 (set-buffer-modified-p modified)))
1283 (w3-region (point-min) (point-max))))) 1286 (w3-region (point-min) (point-max)))))
1284 (insert-buffer-substring work-buffer)) 1287 (insert-buffer-substring work-buffer))
1285 (and work-buffer (kill-buffer work-buffer))) 1288 (and work-buffer (kill-buffer work-buffer)))
1286 (message "Inlining text/html... done") 1289 (message "Inlining text/html... done")
1287 t ) 1290 t )
1288 (vm-set-mm-layout-cache layout "Need W3 to inline HTML") 1291 (vm-set-mm-layout-display-error layout "Need W3 to inline HTML")
1289 nil )) 1292 nil ))
1290 1293
1291 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) 1294 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting)
1292 (let ((start (point)) end old-size 1295 (let ((start (point)) end old-size
1293 (buffer-read-only nil) 1296 (buffer-read-only nil)
1294 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) 1297 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
1295 (if (not (vm-mime-charset-internally-displayable-p charset)) 1298 (if (not (vm-mime-charset-internally-displayable-p charset))
1296 (progn 1299 (progn
1297 (vm-set-mm-layout-cache 1300 (vm-set-mm-layout-display-error
1298 layout (concat "Undisplayable charset: " charset)) 1301 layout (concat "Undisplayable charset: " charset))
1299 nil) 1302 nil)
1300 (vm-mime-insert-mime-body layout) 1303 (vm-mime-insert-mime-body layout)
1301 (setq end (point-marker)) 1304 (setq end (point-marker))
1302 (vm-mime-transfer-decode-region layout start end) 1305 (vm-mime-transfer-decode-region layout start end)
1351 ;; this is a text type. 1354 ;; this is a text type.
1352 (if vm-xemacs-mule-p 1355 (if vm-xemacs-mule-p
1353 (if (vm-mime-text-type-p layout) 1356 (if (vm-mime-text-type-p layout)
1354 (set-buffer-file-coding-system 'no-conversion nil) 1357 (set-buffer-file-coding-system 'no-conversion nil)
1355 (set-buffer-file-coding-system 'binary t))) 1358 (set-buffer-file-coding-system 'binary t)))
1359 ;; Write an empty tempfile out to disk and set its
1360 ;; permissions to 0600, then write the actual buffer
1361 ;; contents to tempfile.
1362 (write-region start start tempfile nil 0)
1363 (set-file-modes tempfile 384)
1356 (write-region start end tempfile nil 0)) 1364 (write-region start end tempfile nil 0))
1357 (delete-region start end) 1365 (delete-region start end)
1358 (save-excursion 1366 (save-excursion
1359 (vm-select-folder-buffer) 1367 (vm-select-folder-buffer)
1360 (setq vm-folder-garbage-alist 1368 (setq vm-folder-garbage-alist
1533 (fset 'vm-mime-display-button-message/news 1541 (fset 'vm-mime-display-button-message/news
1534 'vm-mime-display-button-message/rfc822) 1542 'vm-mime-display-button-message/rfc822)
1535 1543
1536 (defun vm-mime-display-internal-message/rfc822 (layout) 1544 (defun vm-mime-display-internal-message/rfc822 (layout)
1537 (if (vectorp layout) 1545 (if (vectorp layout)
1538 (let ((start (point))) 1546 (let ((start (point))
1539 (vm-mime-insert-mime-headers layout) 1547 (buffer-read-only nil))
1548 (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout)))
1540 (insert ?\n) 1549 (insert ?\n)
1550 (save-excursion
1551 (goto-char start)
1552 (vm-reorder-message-headers nil vm-visible-headers
1553 vm-invisible-header-regexp))
1541 (save-restriction 1554 (save-restriction
1542 (narrow-to-region start (point)) 1555 (narrow-to-region start (point))
1543 (vm-decode-mime-encoded-words)) 1556 (vm-decode-mime-encoded-words))
1544 (vm-mime-display-internal-multipart/mixed layout)) 1557 (vm-mime-display-internal-multipart/mixed layout))
1545 (goto-char (vm-extent-start-position layout)) 1558 (goto-char (vm-extent-start-position layout))
1707 (setq g (vm-mm-layout-cache layout)) 1720 (setq g (vm-mm-layout-cache layout))
1708 (vm-mime-insert-mime-body layout) 1721 (vm-mime-insert-mime-body layout)
1709 (setq end (point-marker)) 1722 (setq end (point-marker))
1710 (vm-mime-transfer-decode-region layout start end) 1723 (vm-mime-transfer-decode-region layout start end)
1711 (setq tempfile (vm-make-tempfile-name)) 1724 (setq tempfile (vm-make-tempfile-name))
1712 ;; coding system for presentation buffer is binary 1725 ;; Write an empty tempfile out to disk and set its
1726 ;; permissions to 0600, then write the actual buffer
1727 ;; contents to tempfile.
1728 (write-region start start tempfile nil 0)
1729 (set-file-modes tempfile 384)
1730 ;; coding system for presentation buffer is binary so
1731 ;; we don't need to set it here.
1713 (write-region start end tempfile nil 0) 1732 (write-region start end tempfile nil 0)
1714 (message "Creating %s glyph..." name) 1733 (message "Creating %s glyph..." name)
1715 (setq g (make-glyph 1734 (setq g (make-glyph
1716 (list (vector feature ':file tempfile) 1735 (list (vector feature ':file tempfile)
1717 (vector 'string 1736 (vector 'string
1759 (setq tempfile (vm-mm-layout-cache layout)) 1778 (setq tempfile (vm-mm-layout-cache layout))
1760 (vm-mime-insert-mime-body layout) 1779 (vm-mime-insert-mime-body layout)
1761 (setq end (point-marker)) 1780 (setq end (point-marker))
1762 (vm-mime-transfer-decode-region layout start end) 1781 (vm-mime-transfer-decode-region layout start end)
1763 (setq tempfile (vm-make-tempfile-name)) 1782 (setq tempfile (vm-make-tempfile-name))
1764 ;; coding system for presentation buffer is binary 1783 ;; Write an empty tempfile out to disk and set its
1784 ;; permissions to 0600, then write the actual buffer
1785 ;; contents to tempfile.
1786 (write-region start start tempfile nil 0)
1787 (set-file-modes tempfile 384)
1788 ;; coding system for presentation buffer is binary, so
1789 ;; we don't need to set it here.
1765 (write-region start end tempfile nil 0) 1790 (write-region start end tempfile nil 0)
1766 (vm-set-mm-layout-cache layout tempfile) 1791 (vm-set-mm-layout-cache layout tempfile)
1767 (save-excursion 1792 (save-excursion
1768 (vm-select-folder-buffer) 1793 (vm-select-folder-buffer)
1769 (setq vm-folder-garbage-alist 1794 (setq vm-folder-garbage-alist
2080 (while (and p (not done)) 2105 (while (and p (not done))
2081 (if (setq result (vm-mime-layout-contains-type (car p) type)) 2106 (if (setq result (vm-mime-layout-contains-type (car p) type))
2082 (setq done t) 2107 (setq done t)
2083 (setq p (cdr p)))) 2108 (setq p (cdr p))))
2084 result ))) 2109 result )))
2110
2111 ;; breadth first traversal
2112 (defun vm-mime-find-digests-in-layout (layout)
2113 (let ((layout-list (list layout))
2114 layout-type
2115 (result nil))
2116 (while layout-list
2117 (setq layout-type (car (vm-mm-layout-type (car layout-list))))
2118 (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)"
2119 layout-type)
2120 (setq result (nconc result (list (car layout-list)))))
2121 ((vm-mime-composite-type-p layout-type)
2122 (setq layout-list (nconc layout-list
2123 (copy-sequence
2124 (vm-mm-layout-parts
2125 (car layout-list)))))))
2126 (setq layout-list (cdr layout-list)))
2127 result ))
2085 2128
2086 (defun vm-mime-plain-message-p (m) 2129 (defun vm-mime-plain-message-p (m)
2087 (save-match-data 2130 (save-match-data
2088 (let ((o (vm-mm-layout m)) 2131 (let ((o (vm-mm-layout m))
2089 (case-fold-search t)) 2132 (case-fold-search t))
2841 (let ((enriched-initial-annotation "")) 2884 (let ((enriched-initial-annotation ""))
2842 (save-excursion 2885 (save-excursion
2843 ;; insert/delete trick needed to avoid 2886 ;; insert/delete trick needed to avoid
2844 ;; enriched-mode tags from seeping into the 2887 ;; enriched-mode tags from seeping into the
2845 ;; attachment overlays. I really wish 2888 ;; attachment overlays. I really wish
2846 ;; front-advance / rear-aadvance overlay 2889 ;; front-advance / rear-advance overlay
2847 ;; endpoint properties actually worked. 2890 ;; endpoint properties actually worked.
2848 (goto-char (point-max)) 2891 (goto-char (point-max))
2849 (insert-before-markers "\n") 2892 (insert-before-markers "\n")
2850 (enriched-encode (point-min) (1- (point))) 2893 (enriched-encode (point-min) (1- (point)))
2851 (goto-char (point-max)) 2894 (goto-char (point-max))
3157 (interactive) 3200 (interactive)
3158 (if (not (eq major-mode 'mail-mode)) 3201 (if (not (eq major-mode 'mail-mode))
3159 (error "Command must be used in a VM Mail mode buffer.")) 3202 (error "Command must be used in a VM Mail mode buffer."))
3160 (let ((temp-buffer nil) 3203 (let ((temp-buffer nil)
3161 (mail-buffer (current-buffer)) 3204 (mail-buffer (current-buffer))
3205 (enriched (and (boundp 'enriched-mode) enriched-mode))
3162 e-list) 3206 e-list)
3163 (unwind-protect 3207 (unwind-protect
3164 (progn 3208 (progn
3165 (setq temp-buffer (generate-new-buffer "composition preview")) 3209 (setq temp-buffer (generate-new-buffer "composition preview"))
3166 (set-buffer temp-buffer) 3210 (set-buffer temp-buffer)
3167 ;; so vm-mime-xxxx-encode-composition won't complain 3211 ;; so vm-mime-xxxx-encode-composition won't complain
3168 (setq major-mode 'mail-mode) 3212 (setq major-mode 'mail-mode)
3213 (set (make-local-variable 'enriched-mode) enriched)
3169 (vm-insert-region-from-buffer mail-buffer) 3214 (vm-insert-region-from-buffer mail-buffer)
3170 (goto-char (point-min)) 3215 (goto-char (point-min))
3171 (or (vm-mail-mode-get-header-contents "From") 3216 (or (vm-mail-mode-get-header-contents "From")
3172 (insert "From: " (user-login-name) "\n")) 3217 (insert "From: " (user-login-name) "\n"))
3173 (or (vm-mail-mode-get-header-contents "Message-ID") 3218 (or (vm-mail-mode-get-header-contents "Message-ID")