Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 114:8619ce7e4c50 r20-1b9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b9
author cvs
date Mon, 13 Aug 2007 09:21:54 +0200
parents fe104dbd9147
children 9f59509498e1
comparison
equal deleted inserted replaced
113:2ec2fe4a4c89 114:8619ce7e4c50
46 (or (vm-mime-layout-of m) 46 (or (vm-mime-layout-of m)
47 (progn (vm-set-mime-layout-of 47 (progn (vm-set-mime-layout-of
48 m 48 m
49 (condition-case data 49 (condition-case data
50 (vm-mime-parse-entity m) 50 (vm-mime-parse-entity m)
51 (vm-mime-error (apply 'message (cdr data))))) 51 (vm-mime-error (message "%s" (car (cdr data))))))
52 (vm-mime-layout-of m)))) 52 (vm-mime-layout-of m))))
53 53
54 (defun vm-mm-encoded-header (m) 54 (defun vm-mm-encoded-header (m)
55 (or (vm-mime-encoded-header-flag-of m) 55 (or (vm-mime-encoded-header-flag-of m)
56 (progn (setq m (vm-real-message-of m)) 56 (progn (setq m (vm-real-message-of m))
382 (while (< inputpos end) 382 (while (< inputpos end)
383 (setq char (char-after inputpos)) 383 (setq char (char-after inputpos))
384 (cond ((= char ?\n) 384 (cond ((= char ?\n)
385 (vm-insert-char char 1 nil work-buffer) 385 (vm-insert-char char 1 nil work-buffer)
386 (setq cols 0)) 386 (setq cols 0))
387 ((and (= char 32) (not (= ?\n (char-after (1+ inputpos))))) 387 ((and (= char 32)
388 (not (= (1+ inputpos) end))
389 (not (= ?\n (char-after (1+ inputpos)))))
388 (vm-insert-char char 1 nil work-buffer) 390 (vm-insert-char char 1 nil work-buffer)
389 (vm-increment cols)) 391 (vm-increment cols))
390 ((or (< char 33) (> char 126) (= char 61) 392 ((or (< char 33) (> char 126) (= char 61)
391 (and quote-from (= cols 0) (let ((case-fold-search nil)) 393 (and quote-from (= cols 0) (let ((case-fold-search nil))
392 (looking-at "From ")))) 394 (looking-at "From "))))
416 (and work-buffer (kill-buffer work-buffer))))) 418 (and work-buffer (kill-buffer work-buffer)))))
417 419
418 (defun vm-decode-mime-message-headers (m) 420 (defun vm-decode-mime-message-headers (m)
419 (let ((case-fold-search t) 421 (let ((case-fold-search t)
420 (buffer-read-only nil) 422 (buffer-read-only nil)
421 (did-decode nil)
422 charset encoding match-start match-end start end) 423 charset encoding match-start match-end start end)
423 (save-excursion 424 (save-excursion
424 (goto-char (vm-headers-of m)) 425 (goto-char (vm-headers-of m))
425 (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t) 426 (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t)
426 (setq match-start (match-beginning 0) 427 (setq match-start (match-beginning 0)
431 end (vm-marker (match-end 3))) 432 end (vm-marker (match-end 3)))
432 ;; don't change anything if we can't display the 433 ;; don't change anything if we can't display the
433 ;; character set properly. 434 ;; character set properly.
434 (if (not (vm-mime-charset-internally-displayable-p charset)) 435 (if (not (vm-mime-charset-internally-displayable-p charset))
435 nil 436 nil
436 (setq did-decode t)
437 (delete-region end match-end) 437 (delete-region end match-end)
438 (condition-case data 438 (condition-case data
439 (cond ((string-match "B" encoding) 439 (cond ((string-match "B" encoding)
440 (vm-mime-B-decode-region start end)) 440 (vm-mime-B-decode-region start end))
441 ((string-match "Q" encoding) 441 ((string-match "Q" encoding)
445 (vm-mime-error (apply 'message (cdr data)) 445 (vm-mime-error (apply 'message (cdr data))
446 (goto-char start) 446 (goto-char start)
447 (insert "**invalid encoded word**") 447 (insert "**invalid encoded word**")
448 (delete-region (point) end))) 448 (delete-region (point) end)))
449 (vm-mime-charset-decode-region charset start end) 449 (vm-mime-charset-decode-region charset start end)
450 (delete-region match-start start))) 450 (delete-region match-start start))))))
451 ;; if we did some decoding, re-electrify the headers since
452 ;; some of the extents might have been wiped by the
453 ;; decoding process.
454 (if did-decode
455 (save-restriction
456 (narrow-to-region (vm-headers-of m) (vm-text-of m))
457 (vm-energize-urls)
458 (vm-highlight-headers-maybe)
459 (vm-energize-headers-and-xfaces))))))
460 451
461 (defun vm-decode-mime-encoded-words () 452 (defun vm-decode-mime-encoded-words ()
462 (let ((case-fold-search t) 453 (let ((case-fold-search t)
463 (buffer-read-only nil) 454 (buffer-read-only nil)
464 charset encoding match-start match-end start end) 455 charset encoding match-start match-end start end)
630 621
631 (defun vm-mime-parse-entity (&optional m default-type default-encoding) 622 (defun vm-mime-parse-entity (&optional m default-type default-encoding)
632 (let ((case-fold-search t) version type qtype encoding id description 623 (let ((case-fold-search t) version type qtype encoding id description
633 disposition qdisposition boundary boundary-regexp start 624 disposition qdisposition boundary boundary-regexp start
634 multipart-list c-t c-t-e done p returnval) 625 multipart-list c-t c-t-e done p returnval)
635 (and m (message "Parsing MIME message..."))
636 (prog1
637 (catch 'return-value 626 (catch 'return-value
638 (save-excursion 627 (save-excursion
639 (if m 628 (if m
640 (progn 629 (progn
641 (setq m (vm-real-message-of m)) 630 (setq m (vm-real-message-of m))
699 (vm-mime-parse-content-header 688 (vm-mime-parse-content-header
700 disposition ?\;)))) 689 disposition ?\;))))
701 (cond ((null m) t) 690 (cond ((null m) t)
702 ((null version) 691 ((null version)
703 (throw 'return-value 'none)) 692 (throw 'return-value 'none))
704 ((string= version "1.0") t) 693 ((or vm-mime-ignore-mime-version (string= version "1.0")) t)
705 (t (vm-mime-error "Unsupported MIME version: %s" version))) 694 (t (vm-mime-error "Unsupported MIME version: %s" version)))
706 (cond ((and m (null type)) 695 (cond ((and m (null type))
707 (throw 'return-value 696 (throw 'return-value
708 (vector '("text/plain" "charset=us-ascii") 697 (vector '("text/plain" "charset=us-ascii")
709 '("text/plain" "charset=us-ascii") 698 '("text/plain" "charset=us-ascii")
812 disposition qdisposition 801 disposition qdisposition
813 (vm-marker (point-min)) 802 (vm-marker (point-min))
814 (vm-marker (point)) 803 (vm-marker (point))
815 (vm-marker (point-max)) 804 (vm-marker (point-max))
816 (nreverse multipart-list) 805 (nreverse multipart-list)
817 nil ))))) 806 nil )))))))
818 (and m (message "Parsing MIME message... done"))
819 )))
820 807
821 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) 808 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e)
822 (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) 809 (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
823 ;; don't let subpart parse errors make the whole parse fail. use default 810 ;; don't let subpart parse errors make the whole parse fail. use default
824 ;; type if the parse fails. 811 ;; type if the parse fails.
928 (vm-set-hooks-for-frame-deletion)) 915 (vm-set-hooks-for-frame-deletion))
929 (use-local-map vm-mode-map) 916 (use-local-map vm-mode-map)
930 (and (vm-toolbar-support-possible-p) vm-use-toolbar 917 (and (vm-toolbar-support-possible-p) vm-use-toolbar
931 (vm-toolbar-install-toolbar)) 918 (vm-toolbar-install-toolbar))
932 (and (vm-menu-support-possible-p) 919 (and (vm-menu-support-possible-p)
933 (vm-menu-install-menus))) 920 (vm-menu-install-menus))
921 (run-hooks 'vm-presentation-mode-hook))
934 (setq vm-presentation-buffer-handle b))) 922 (setq vm-presentation-buffer-handle b)))
935 (setq b vm-presentation-buffer-handle 923 (setq b vm-presentation-buffer-handle
936 vm-presentation-buffer vm-presentation-buffer-handle 924 vm-presentation-buffer vm-presentation-buffer-handle
937 vm-mime-decoded nil) 925 vm-mime-decoded nil)
938 (save-excursion 926 (save-excursion
1079 ((or (vm-mime-types-match "text/plain" type) 1067 ((or (vm-mime-types-match "text/plain" type)
1080 (vm-mime-types-match "text/enriched" type)) 1068 (vm-mime-types-match "text/enriched" type))
1081 (let ((charset (or (vm-mime-get-parameter layout "charset") 1069 (let ((charset (or (vm-mime-get-parameter layout "charset")
1082 "us-ascii"))) 1070 "us-ascii")))
1083 (vm-mime-charset-internally-displayable-p charset))) 1071 (vm-mime-charset-internally-displayable-p charset)))
1084 ;; commented out until I decide whether W3 is safe to use in 1072 ;; commented out until w3-region behavior gets worked out
1085 ;; light of the porposed javascript extension and the possibility
1086 ;; of executing arbitrary Emacs-Lisp code embedded in a page.
1087 ;; 1073 ;;
1088 ;; ((vm-mime-types-match "text/html" type) 1074 ;; ((vm-mime-types-match "text/html" type)
1089 ;; (condition-case () 1075 ;; (condition-case ()
1090 ;; (progn (require 'w3) 1076 ;; (progn (require 'w3)
1091 ;; (fboundp 'w3-region)) 1077 ;; (fboundp 'w3-region))
1275 (and (not (eq (vm-mm-encoded-header m) 'none)) 1261 (and (not (eq (vm-mm-encoded-header m) 'none))
1276 (vm-decode-mime-message-headers m)) 1262 (vm-decode-mime-message-headers m))
1277 (if (vectorp layout) 1263 (if (vectorp layout)
1278 (progn 1264 (progn
1279 (vm-decode-mime-layout layout) 1265 (vm-decode-mime-layout layout)
1280 (delete-region (point) (point-max))))) 1266 (delete-region (point) (point-max))))
1267 (vm-energize-urls)
1268 (vm-highlight-headers-maybe)
1269 (vm-energize-headers-and-xfaces))
1281 (set-buffer-modified-p modified)))) 1270 (set-buffer-modified-p modified))))
1282 (save-excursion (set-buffer vm-mail-buffer) 1271 (save-excursion (set-buffer vm-mail-buffer)
1283 (setq vm-mime-decoded 'decoded)) 1272 (setq vm-mime-decoded 'decoded))
1284 (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) 1273 (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update)
1285 (vm-update-summary-and-mode-line) 1274 (vm-update-summary-and-mode-line)
1347 t ) 1336 t )
1348 1337
1349 (defun vm-mime-display-button-text (layout) 1338 (defun vm-mime-display-button-text (layout)
1350 (vm-mime-display-button-xxxx layout t)) 1339 (vm-mime-display-button-xxxx layout t))
1351 1340
1352 ;; commented out until I decide whether W3 is safe to use in 1341 ;; commented out until w3-region behavior is worked out
1353 ;; light of the proposed javascript extension and the possibility
1354 ;; of executing arbitrary Emacs-Lisp code embedded in a page.
1355 ;; 1342 ;;
1356 ;;(defun vm-mime-display-internal-text/html (layout) 1343 ;;(defun vm-mime-display-internal-text/html (layout)
1357 ;; (let ((buffer-read-only nil) 1344 ;; (let ((buffer-read-only nil)
1358 ;; (work-buffer nil)) 1345 ;; (work-buffer nil))
1359 ;; (message "Inlining text/html, be patient...") 1346 ;; (message "Inlining text/html, be patient...")
1372 ;; (insert-buffer-substring work-buffer)) 1359 ;; (insert-buffer-substring work-buffer))
1373 ;; (and work-buffer (kill-buffer work-buffer))) 1360 ;; (and work-buffer (kill-buffer work-buffer)))
1374 ;; (message "Inlining text/html... done") 1361 ;; (message "Inlining text/html... done")
1375 ;; t )) 1362 ;; t ))
1376 1363
1377 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) 1364 (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting)
1378 (let ((start (point)) end old-size 1365 (let ((start (point)) end old-size
1379 (buffer-read-only nil) 1366 (buffer-read-only nil)
1380 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) 1367 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
1381 (if (not (vm-mime-charset-internally-displayable-p charset)) 1368 (if (not (vm-mime-charset-internally-displayable-p charset))
1382 (progn 1369 (progn
1387 (setq end (point-marker)) 1374 (setq end (point-marker))
1388 (vm-mime-transfer-decode-region layout start end) 1375 (vm-mime-transfer-decode-region layout start end)
1389 (setq old-size (buffer-size)) 1376 (setq old-size (buffer-size))
1390 (vm-mime-charset-decode-region charset start end) 1377 (vm-mime-charset-decode-region charset start end)
1391 (set-marker end (+ end (- (buffer-size) old-size))) 1378 (set-marker end (+ end (- (buffer-size) old-size)))
1392 (or ignore-urls (vm-energize-urls-in-message-region start end)) 1379 (or no-highlighting (vm-energize-urls-in-message-region start end))
1393 (goto-char end) 1380 (goto-char end)
1394 t ))) 1381 t )))
1395 1382
1396 (defun vm-mime-display-internal-text/enriched (layout) 1383 (defun vm-mime-display-internal-text/enriched (layout)
1397 (require 'enriched) 1384 (require 'enriched)
1592 (vm-save-buffer-excursion 1579 (vm-save-buffer-excursion
1593 (vm-goto-new-folder-frame-maybe 'folder) 1580 (vm-goto-new-folder-frame-maybe 'folder)
1594 (vm-mode)) 1581 (vm-mode))
1595 ;; temp buffer, don't offer to save it. 1582 ;; temp buffer, don't offer to save it.
1596 (setq buffer-offer-save nil) 1583 (setq buffer-offer-save nil)
1597 (vm-display nil nil (list this-command) '(vm-mode startup))) 1584 (vm-display (or vm-presentation-buffer (current-buffer)) t
1585 (list this-command) '(vm-mode startup)))
1598 t ) 1586 t )
1599 (fset 'vm-mime-display-button-multipart/digest 1587 (fset 'vm-mime-display-button-multipart/digest
1600 'vm-mime-display-internal-multipart/digest) 1588 'vm-mime-display-internal-multipart/digest)
1601 1589
1602 (defun vm-mime-display-internal-message/rfc822 (layout) 1590 (defun vm-mime-display-internal-message/rfc822 (layout)
2588 (forward-char -1) 2576 (forward-char -1)
2589 (insert-buffer-substring object) 2577 (insert-buffer-substring object)
2590 (delete-char 1))) 2578 (delete-char 1)))
2591 ((stringp object) 2579 ((stringp object)
2592 (let ((coding-system-for-read 'no-conversion)) 2580 (let ((coding-system-for-read 'no-conversion))
2593 (insert-file-contents-literally object)))) 2581 (insert-before-markers " ")
2582 (forward-char -1)
2583 (insert-file-contents-literally object)
2584 (delete-char 1))))
2594 ;; gather information about the object from the extent. 2585 ;; gather information about the object from the extent.
2595 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) 2586 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded))
2596 (setq layout (vm-mime-parse-entity 2587 (setq layout (vm-mime-parse-entity
2597 nil (list "text/plain" "charset=us-ascii") 2588 nil (list "text/plain" "charset=us-ascii")
2598 "7bit") 2589 "7bit")
2893 ;; so vm-mime-encode-composition won't complain 2884 ;; so vm-mime-encode-composition won't complain
2894 (setq major-mode 'mail-mode) 2885 (setq major-mode 'mail-mode)
2895 (vm-insert-region-from-buffer mail-buffer) 2886 (vm-insert-region-from-buffer mail-buffer)
2896 (goto-char (point-min)) 2887 (goto-char (point-min))
2897 (or (vm-mail-mode-get-header-contents "From") 2888 (or (vm-mail-mode-get-header-contents "From")
2898 (insert "From: " (or user-mail-address (user-login-name)) "\n")) 2889 (insert "From: " (user-login-name) "\n"))
2899 (or (vm-mail-mode-get-header-contents "Message-ID") 2890 (or (vm-mail-mode-get-header-contents "Message-ID")
2900 (insert "Message-ID: <fake@fake.fake>\n")) 2891 (insert "Message-ID: <fake@fake.fake>\n"))
2901 (or (vm-mail-mode-get-header-contents "Date") 2892 (or (vm-mail-mode-get-header-contents "Date")
2902 (insert "Date: " 2893 (insert "Date: "
2903 (format-time-string "%a, %d %b %Y %H%M%S %Z" 2894 (format-time-string "%a, %d %b %Y %H%M%S %Z"