Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 441bb1e64a06
children c53a95d3c46d fe104dbd9147
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
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 (defun vm-mm-layout-cache (e) (aref e 11))
41 41
42 (defun vm-set-mm-layout-type (e type) (aset e 0 type))
42 (defun vm-set-mm-layout-cache (e c) (aset e 11 c)) 43 (defun vm-set-mm-layout-cache (e c) (aset e 11 c))
43 44
44 (defun vm-mm-layout (m) 45 (defun vm-mm-layout (m)
45 (or (vm-mime-layout-of m) 46 (or (vm-mime-layout-of m)
46 (progn (vm-set-mime-layout-of 47 (progn (vm-set-mime-layout-of
360 (delete-region (point) end)) 361 (delete-region (point) end))
361 (and work-buffer (kill-buffer work-buffer)))) 362 (and work-buffer (kill-buffer work-buffer))))
362 (and (> (- end start) 200) 363 (and (> (- end start) 200)
363 (message "Decoding quoted-printable... done"))) 364 (message "Decoding quoted-printable... done")))
364 365
365 (defun vm-mime-qp-encode-region (start end &optional Q-encoding) 366 (defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from)
366 (and (> (- end start) 200) 367 (and (> (- end start) 200)
367 (message "Encoding quoted-printable...")) 368 (message "Encoding quoted-printable..."))
368 (let ((work-buffer nil) 369 (let ((work-buffer nil)
369 (buf (current-buffer)) 370 (buf (current-buffer))
370 (cols 0) 371 (cols 0)
384 (vm-insert-char char 1 nil work-buffer) 385 (vm-insert-char char 1 nil work-buffer)
385 (setq cols 0)) 386 (setq cols 0))
386 ((and (= char 32) (not (= ?\n (char-after (1+ inputpos))))) 387 ((and (= char 32) (not (= ?\n (char-after (1+ inputpos)))))
387 (vm-insert-char char 1 nil work-buffer) 388 (vm-insert-char char 1 nil work-buffer)
388 (vm-increment cols)) 389 (vm-increment cols))
389 ((or (< char 33) (> char 126) (= char 61)) 390 ((or (< char 33) (> char 126) (= char 61)
391 (and quote-from (= cols 0) (let ((case-fold-search nil))
392 (looking-at "From "))))
390 (vm-insert-char ?= 1 nil work-buffer) 393 (vm-insert-char ?= 1 nil work-buffer)
391 (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist)) 394 (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist))
392 1 nil work-buffer) 395 1 nil work-buffer)
393 (vm-insert-char (car (rassq (logand char 15) 396 (vm-insert-char (car (rassq (logand char 15)
394 hex-digit-alist)) 397 hex-digit-alist))
413 (and work-buffer (kill-buffer work-buffer))))) 416 (and work-buffer (kill-buffer work-buffer)))))
414 417
415 (defun vm-decode-mime-message-headers (m) 418 (defun vm-decode-mime-message-headers (m)
416 (let ((case-fold-search t) 419 (let ((case-fold-search t)
417 (buffer-read-only nil) 420 (buffer-read-only nil)
421 (did-decode nil)
418 charset encoding match-start match-end start end) 422 charset encoding match-start match-end start end)
419 (save-excursion 423 (save-excursion
420 (goto-char (vm-headers-of m)) 424 (goto-char (vm-headers-of m))
421 (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t) 425 (while (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t)
422 (setq match-start (match-beginning 0) 426 (setq match-start (match-beginning 0)
423 match-end (match-end 0) 427 match-end (match-end 0)
424 charset (match-string 1) 428 charset (buffer-substring (match-beginning 1) (match-end 1))
425 encoding (match-string 2) 429 encoding (buffer-substring (match-beginning 2) (match-end 2))
426 start (match-beginning 3) 430 start (match-beginning 3)
427 end (vm-marker (match-end 3))) 431 end (vm-marker (match-end 3)))
428 ;; don't change anything if we can't display the 432 ;; don't change anything if we can't display the
429 ;; character set properly. 433 ;; character set properly.
430 (if (not (vm-mime-charset-internally-displayable-p charset)) 434 (if (not (vm-mime-charset-internally-displayable-p charset))
431 nil 435 nil
436 (setq did-decode t)
432 (delete-region end match-end) 437 (delete-region end match-end)
433 (cond ((string-match "B" encoding) 438 (condition-case data
434 (vm-mime-B-decode-region start end)) 439 (cond ((string-match "B" encoding)
435 ((string-match "Q" encoding) 440 (vm-mime-B-decode-region start end))
436 (vm-mime-Q-decode-region start end)) 441 ((string-match "Q" encoding)
437 (t (vm-mime-error "unknown encoded word encoding, %s" 442 (vm-mime-Q-decode-region start end))
438 encoding))) 443 (t (vm-mime-error "unknown encoded word encoding, %s"
444 encoding)))
445 (vm-mime-error (apply 'message (cdr data))
446 (goto-char start)
447 (insert "**invalid encoded word**")
448 (delete-region (point) end)))
439 (vm-mime-charset-decode-region charset start end) 449 (vm-mime-charset-decode-region charset start end)
440 (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))))))
441 460
442 (defun vm-decode-mime-encoded-words () 461 (defun vm-decode-mime-encoded-words ()
443 (let ((case-fold-search t) 462 (let ((case-fold-search t)
444 (buffer-read-only nil) 463 (buffer-read-only nil)
445 charset encoding match-start match-end start end) 464 charset encoding match-start match-end start end)
446 (save-excursion 465 (save-excursion
447 (goto-char (point-min)) 466 (goto-char (point-min))
448 (while (re-search-forward vm-mime-encoded-word-regexp nil t) 467 (while (re-search-forward vm-mime-encoded-word-regexp nil t)
449 (setq match-start (match-beginning 0) 468 (setq match-start (match-beginning 0)
450 match-end (match-end 0) 469 match-end (match-end 0)
451 charset (match-string 1) 470 charset (buffer-substring (match-beginning 1) (match-end 1))
452 encoding (match-string 2) 471 encoding (buffer-substring (match-beginning 2) (match-end 2))
453 start (match-beginning 3) 472 start (match-beginning 3)
454 end (vm-marker (match-end 3))) 473 end (vm-marker (match-end 3)))
455 ;; don't change anything if we can't display the 474 ;; don't change anything if we can't display the
456 ;; character set properly. 475 ;; character set properly.
457 (if (not (vm-mime-charset-internally-displayable-p charset)) 476 (if (not (vm-mime-charset-internally-displayable-p charset))
458 nil 477 nil
459 (delete-region end match-end) 478 (delete-region end match-end)
460 (cond ((string-match "B" encoding) 479 (condition-case data
461 (vm-mime-B-decode-region start end)) 480 (cond ((string-match "B" encoding)
462 ((string-match "Q" encoding) 481 (vm-mime-B-decode-region start end))
463 (vm-mime-Q-decode-region start end)) 482 ((string-match "Q" encoding)
464 (t (vm-mime-error "unknown encoded word encoding, %s" 483 (vm-mime-Q-decode-region start end))
465 encoding))) 484 (t (vm-mime-error "unknown encoded word encoding, %s"
485 encoding)))
486 (vm-mime-error (apply 'message (cdr data))
487 (goto-char start)
488 (insert "**invalid encoded word**")
489 (delete-region (point) end)))
466 (vm-mime-charset-decode-region charset start end) 490 (vm-mime-charset-decode-region charset start end)
467 (delete-region match-start start)))))) 491 (delete-region match-start start))))))
468 492
469 (defun vm-decode-mime-encoded-words-in-string (string) 493 (defun vm-decode-mime-encoded-words-in-string (string)
470 (if (and vm-display-using-mime 494 (if (and vm-display-using-mime
713 (setq c-t '("message/rfc822") 737 (setq c-t '("message/rfc822")
714 c-t-e "7bit")) 738 c-t-e "7bit"))
715 ((string-match "^multipart/" (car type)) 739 ((string-match "^multipart/" (car type))
716 (setq c-t '("text/plain" "charset=us-ascii") 740 (setq c-t '("text/plain" "charset=us-ascii")
717 c-t-e "7bit")) ; below 741 c-t-e "7bit")) ; below
718 ((string-match "^message/rfc822" (car type)) 742 ((string-match "^message/\\(rfc822\\|news\\)" (car type))
719 (setq c-t '("text/plain" "charset=us-ascii") 743 (setq c-t '("text/plain" "charset=us-ascii")
720 c-t-e "7bit") 744 c-t-e "7bit")
721 (goto-char (point-min)) 745 (goto-char (point-min))
722 (or (re-search-forward "^\n\\|\n\\'" nil t) 746 (or (re-search-forward "^\n\\|\n\\'" nil t)
723 (vm-mime-error "MIME part missing header/body separator line")) 747 (vm-mime-error "MIME part missing header/body separator line"))
883 ;; Default to binary file type for DOS/NT. 907 ;; Default to binary file type for DOS/NT.
884 buffer-file-type t 908 buffer-file-type t
885 ;; Tell XEmacs/MULE not to mess with the text on writes. 909 ;; Tell XEmacs/MULE not to mess with the text on writes.
886 buffer-read-only t 910 buffer-read-only t
887 mode-line-format vm-mode-line-format) 911 mode-line-format vm-mode-line-format)
912 ;; scroll in place messes with scroll-up and this loses
913 (defvar scroll-in-place)
914 (make-local-variable 'scroll-in-place)
915 (setq scroll-in-place nil)
888 (and (vm-xemacs-mule-p) 916 (and (vm-xemacs-mule-p)
889 (set-file-coding-system 'binary t)) 917 (set-file-coding-system 'binary t))
890 (cond ((vm-fsfemacs-19-p) 918 (cond ((vm-fsfemacs-19-p)
891 ;; need to do this outside the let because 919 ;; need to do this outside the let because
892 ;; loading disp-table initializes 920 ;; loading disp-table initializes
894 (require 'disp-table) 922 (require 'disp-table)
895 (let* ((standard-display-table 923 (let* ((standard-display-table
896 (copy-sequence standard-display-table))) 924 (copy-sequence standard-display-table)))
897 (standard-display-european t) 925 (standard-display-european t)
898 (setq buffer-display-table standard-display-table)))) 926 (setq buffer-display-table standard-display-table))))
899 (if vm-frame-per-folder 927 (if (and vm-frame-per-folder (vm-multiple-frames-possible-p))
900 (vm-set-hooks-for-frame-deletion)) 928 (vm-set-hooks-for-frame-deletion))
901 (use-local-map vm-mode-map) 929 (use-local-map vm-mode-map)
902 (and (vm-toolbar-support-possible-p) vm-use-toolbar 930 (and (vm-toolbar-support-possible-p) vm-use-toolbar
903 (vm-toolbar-install-toolbar)) 931 (vm-toolbar-install-toolbar))
904 (and (vm-menu-support-possible-p) 932 (and (vm-menu-support-possible-p)
967 (assoc (coding-system-name file-coding-system) 995 (assoc (coding-system-name file-coding-system)
968 vm-mime-mule-coding-to-charset-alist))) 996 vm-mime-mule-coding-to-charset-alist)))
969 "iso-2022-jp")) 997 "iso-2022-jp"))
970 (t 998 (t
971 (or (car (cdr 999 (or (car (cdr
972 (vm-string-assoc 1000 (assoc
973 (car charsets) 1001 (car charsets)
974 vm-mime-mule-charset-to-charset-alist))) 1002 vm-mime-mule-charset-to-charset-alist)))
975 "unknown")))) 1003 "unknown"))))
976 (and (re-search-forward "[^\000-\177]" nil t) 1004 (and (re-search-forward "[^\000-\177]" nil t)
977 (throw 'done (or vm-mime-8bit-composition-charset 1005 (throw 'done (or vm-mime-8bit-composition-charset
1307 ((and (or (vm-mime-types-match "message" type) 1335 ((and (or (vm-mime-types-match "message" type)
1308 (vm-mime-types-match "text" type)) 1336 (vm-mime-types-match "text" type))
1309 ;; display unmatched message and text types as 1337 ;; display unmatched message and text types as
1310 ;; text/plain. 1338 ;; text/plain.
1311 (vm-mime-display-internal-text/plain layout))) 1339 (vm-mime-display-internal-text/plain layout)))
1312 (t (vm-mime-display-internal-application/octet-stream 1340 (t (and extent (vm-mime-rewrite-failed-button
1341 extent (vm-mm-layout-cache layout)))
1342 (vm-mime-display-internal-application/octet-stream
1313 (or extent layout)))) 1343 (or extent layout))))
1314 (and extent (vm-mime-delete-button-maybe extent))) 1344 (and extent (vm-mime-delete-button-maybe extent)))
1315 (set-buffer-modified-p modified))) 1345 (set-buffer-modified-p modified)))
1316 t ) 1346 t )
1317 1347
1346 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) 1376 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls)
1347 (let ((start (point)) end old-size 1377 (let ((start (point)) end old-size
1348 (buffer-read-only nil) 1378 (buffer-read-only nil)
1349 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) 1379 (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")))
1350 (if (not (vm-mime-charset-internally-displayable-p charset)) 1380 (if (not (vm-mime-charset-internally-displayable-p charset))
1351 nil 1381 (progn
1382 (vm-set-mm-layout-cache
1383 layout (concat "Undisplayable charset: " charset))
1384 nil)
1352 (vm-mime-insert-mime-body layout) 1385 (vm-mime-insert-mime-body layout)
1353 (setq end (point-marker)) 1386 (setq end (point-marker))
1354 (vm-mime-transfer-decode-region layout start end) 1387 (vm-mime-transfer-decode-region layout start end)
1355 (setq old-size (buffer-size)) 1388 (setq old-size (buffer-size))
1356 (vm-mime-charset-decode-region charset start end) 1389 (vm-mime-charset-decode-region charset start end)
1387 (tempfile (nth 1 (vm-mm-layout-cache layout))) 1420 (tempfile (nth 1 (vm-mm-layout-cache layout)))
1388 (buffer-read-only nil) 1421 (buffer-read-only nil)
1389 (start (point)) 1422 (start (point))
1390 end) 1423 end)
1391 (if (and (processp process) (eq (process-status process) 'run)) 1424 (if (and (processp process) (eq (process-status process) 'run))
1392 nil 1425 t
1393 (cond ((or (null tempfile) (null (file-exists-p tempfile))) 1426 (cond ((or (null tempfile) (null (file-exists-p tempfile)))
1394 (vm-mime-insert-mime-body layout) 1427 (vm-mime-insert-mime-body layout)
1395 (setq end (point-marker)) 1428 (setq end (point-marker))
1396 (vm-mime-transfer-decode-region layout start end) 1429 (vm-mime-transfer-decode-region layout start end)
1397 (setq tempfile (vm-make-tempfile-name)) 1430 (setq tempfile (vm-make-tempfile-name))
1410 (save-excursion 1443 (save-excursion
1411 (vm-select-folder-buffer) 1444 (vm-select-folder-buffer)
1412 (setq vm-folder-garbage-alist 1445 (setq vm-folder-garbage-alist
1413 (cons (cons tempfile 'delete-file) 1446 (cons (cons tempfile 'delete-file)
1414 vm-folder-garbage-alist))))) 1447 vm-folder-garbage-alist)))))
1415 (message "Launching %s..." (mapconcat 'identity 1448 (message "Launching %s..." (mapconcat 'identity program-list " "))
1416 program-list
1417 " "))
1418 (setq process 1449 (setq process
1419 (apply 'start-process 1450 (apply 'start-process
1420 (format "view %25s" (vm-mime-layout-description layout)) 1451 (format "view %25s" (vm-mime-layout-description layout))
1421 nil (append program-list (list tempfile)))) 1452 nil (append program-list (list tempfile))))
1422 (process-kill-without-query process t) 1453 (process-kill-without-query process t)
1598 (setq buffer-offer-save nil) 1629 (setq buffer-offer-save nil)
1599 (vm-display (or vm-presentation-buffer (current-buffer)) t 1630 (vm-display (or vm-presentation-buffer (current-buffer)) t
1600 (list this-command) '(vm-mode startup))) 1631 (list this-command) '(vm-mode startup)))
1601 t ) 1632 t )
1602 (fset 'vm-mime-display-button-message/rfc822 1633 (fset 'vm-mime-display-button-message/rfc822
1634 'vm-mime-display-internal-message/rfc822)
1635 (fset 'vm-mime-display-internal-message/news
1603 'vm-mime-display-internal-message/rfc822) 1636 'vm-mime-display-internal-message/rfc822)
1604 1637
1605 (defun vm-mime-display-internal-message/partial (layout) 1638 (defun vm-mime-display-internal-message/partial (layout)
1606 (if (vectorp layout) 1639 (if (vectorp layout)
1607 (let ((buffer-read-only nil) 1640 (let ((buffer-read-only nil)
1827 (let ((vm-auto-displayed-mime-content-types t)) 1860 (let ((vm-auto-displayed-mime-content-types t))
1828 (vm-decode-mime-layout layout t))))) 1861 (vm-decode-mime-layout layout t)))))
1829 layout disposable) 1862 layout disposable)
1830 t )) 1863 t ))
1831 1864
1832 (defun vm-mime-run-display-function-at-point (&optional function) 1865 (defun vm-mime-run-display-function-at-point (&optional function dispose)
1833 (interactive) 1866 (interactive)
1834 ;; save excursion to keep point from moving. its motion would 1867 ;; save excursion to keep point from moving. its motion would
1835 ;; drag window point along, to a place arbitrarily far from 1868 ;; drag window point along, to a place arbitrarily far from
1836 ;; where it was when the user triggered the button. 1869 ;; where it was when the user triggered the button.
1837 (save-excursion 1870 (save-excursion
1894 (defun vm-mime-insert-button (caption action layout disposable) 1927 (defun vm-mime-insert-button (caption action layout disposable)
1895 (let ((start (point)) e 1928 (let ((start (point)) e
1896 (keymap (make-sparse-keymap)) 1929 (keymap (make-sparse-keymap))
1897 (buffer-read-only nil)) 1930 (buffer-read-only nil))
1898 (if (fboundp 'set-keymap-parents) 1931 (if (fboundp 'set-keymap-parents)
1899 (set-keymap-parents keymap (list (current-local-map))) 1932 (if (current-local-map)
1933 (set-keymap-parents keymap (list (current-local-map))))
1900 (setq keymap (nconc keymap (current-local-map)))) 1934 (setq keymap (nconc keymap (current-local-map))))
1901 (define-key keymap "\r" 'vm-mime-run-display-function-at-point) 1935 (define-key keymap "\r" 'vm-mime-run-display-function-at-point)
1902 (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3) 1936 (if (and (vm-mouse-xemacs-mouse-p) vm-popup-menu-on-mouse-3)
1903 (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu)) 1937 (define-key keymap 'button3 'vm-menu-popup-mime-dispose-menu))
1904 (if (not (bolp)) 1938 (if (not (bolp))
1924 ;; for all 1958 ;; for all
1925 (vm-set-extent-property e 'vm-mime-disposable disposable) 1959 (vm-set-extent-property e 'vm-mime-disposable disposable)
1926 (vm-set-extent-property e 'face vm-mime-button-face) 1960 (vm-set-extent-property e 'face vm-mime-button-face)
1927 (vm-set-extent-property e 'vm-mime-layout layout) 1961 (vm-set-extent-property e 'vm-mime-layout layout)
1928 (vm-set-extent-property e 'vm-mime-function action))) 1962 (vm-set-extent-property e 'vm-mime-function action)))
1963
1964 (defun vm-mime-rewrite-failed-button (button error-string)
1965 (let* ((buffer-read-only nil)
1966 (start (point)))
1967 (goto-char (vm-extent-start-position button))
1968 (insert (format "DISPLAY FAILED -- %s" error-string))
1969 (vm-set-extent-endpoints button start (vm-extent-end-position button))
1970 (delete-region (point) (vm-extent-end-position button))))
1929 1971
1930 (defun vm-mime-send-body-to-file (layout &optional default-filename) 1972 (defun vm-mime-send-body-to-file (layout &optional default-filename)
1931 (if (not (vectorp layout)) 1973 (if (not (vectorp layout))
1932 (setq layout (vm-extent-property layout 'vm-mime-layout))) 1974 (setq layout (vm-extent-property layout 'vm-mime-layout)))
1933 (or default-filename 1975 (or default-filename
1980 (y-or-n-p "File exists, overwrite? ") 2022 (y-or-n-p "File exists, overwrite? ")
1981 (error "Aborted")) 2023 (error "Aborted"))
1982 (write-region (point-min) (point-max) file nil nil)) 2024 (write-region (point-min) (point-max) file nil nil))
1983 (and work-buffer (kill-buffer work-buffer)))))) 2025 (and work-buffer (kill-buffer work-buffer))))))
1984 2026
1985 (defun vm-mime-pipe-body-to-command (layout &optional discard-output) 2027 (defun vm-mime-pipe-body-to-command (command layout &optional discard-output)
1986 (if (not (vectorp layout)) 2028 (if (not (vectorp layout))
1987 (setq layout (vm-extent-property layout 'vm-mime-layout))) 2029 (setq layout (vm-extent-property layout 'vm-mime-layout)))
1988 (let ((command-line (read-string "Pipe to command: ")) 2030 (let ((output-buffer (if discard-output
1989 (output-buffer (if discard-output
1990 0 2031 0
1991 (get-buffer-create "*Shell Command Output*"))) 2032 (get-buffer-create "*Shell Command Output*")))
1992 (work-buffer nil)) 2033 (work-buffer nil))
1993 (save-excursion 2034 (save-excursion
1994 (if (bufferp output-buffer) 2035 (if (bufferp output-buffer)
2007 ;; Tell DOS/Windows NT whether the input is binary 2048 ;; Tell DOS/Windows NT whether the input is binary
2008 (binary-process-input (not (vm-mime-text-type-p layout)))) 2049 (binary-process-input (not (vm-mime-text-type-p layout))))
2009 (call-process-region (point-min) (point-max) 2050 (call-process-region (point-min) (point-max)
2010 (or shell-file-name "sh") 2051 (or shell-file-name "sh")
2011 nil output-buffer nil 2052 nil output-buffer nil
2012 shell-command-switch command-line))) 2053 shell-command-switch command)))
2013 (and work-buffer (kill-buffer work-buffer))) 2054 (and work-buffer (kill-buffer work-buffer)))
2014 (if (bufferp output-buffer) 2055 (if (bufferp output-buffer)
2015 (progn 2056 (progn
2016 (set-buffer output-buffer) 2057 (set-buffer output-buffer)
2017 (if (not (zerop (buffer-size))) 2058 (if (not (zerop (buffer-size)))
2019 '(vm-pipe-message-to-command)) 2060 '(vm-pipe-message-to-command))
2020 (vm-display nil nil (list this-command) 2061 (vm-display nil nil (list this-command)
2021 '(vm-pipe-message-to-command))))))) 2062 '(vm-pipe-message-to-command)))))))
2022 t ) 2063 t )
2023 2064
2024 (defun vm-mime-pipe-body-to-command-discard-output (layout) 2065 (defun vm-mime-pipe-body-to-queried-command (layout &optional discard-output)
2025 (vm-mime-pipe-body-to-command layout t)) 2066 (let ((command (read-string "Pipe to command: ")))
2067 (vm-mime-pipe-body-to-command command layout discard-output)))
2068
2069 (defun vm-mime-pipe-body-to-queried-command-discard-output (layout)
2070 (vm-mime-pipe-body-to-queried-command layout t))
2071
2072 (defun vm-mime-send-body-to-printer (layout)
2073 (vm-mime-pipe-body-to-command (mapconcat (function identity)
2074 (nconc (list vm-print-command)
2075 vm-print-command-switches)
2076 " ")
2077 layout))
2078
2079 (defun vm-mime-display-body-as-text (button)
2080 (let ((vm-auto-displayed-mime-content-types '("text/plain"))
2081 (layout (copy-sequence (vm-extent-property button 'vm-mime-layout))))
2082 (vm-set-extent-property button 'vm-mime-disposable t)
2083 (vm-set-extent-property button 'vm-mime-layout layout)
2084 ;; not universally correct, but close enough.
2085 (vm-set-mm-layout-type layout '("text/plain" "charset=us-ascii"))
2086 (goto-char (vm-extent-start-position button))
2087 (vm-decode-mime-layout button t)))
2088
2089 (defun vm-mime-display-body-using-external-viewer (button)
2090 (let ((layout (vm-extent-property button 'vm-mime-layout)))
2091 (goto-char (vm-extent-start-position button))
2092 (if (not (vm-mime-find-external-viewer (car (vm-mm-layout-type layout))))
2093 (error "No viewer defined for type %s"
2094 (car (vm-mm-layout-type layout)))
2095 (vm-mime-display-external-generic layout))))
2026 2096
2027 (defun vm-mime-scrub-description (string) 2097 (defun vm-mime-scrub-description (string)
2028 (let ((work-buffer nil)) 2098 (let ((work-buffer nil))
2029 (save-excursion 2099 (save-excursion
2030 (unwind-protect 2100 (unwind-protect
2258 (setq start (point) 2328 (setq start (point)
2259 tag-string (format "[ATTACHMENT %s, %s]" object 2329 tag-string (format "[ATTACHMENT %s, %s]" object
2260 (or type "MIME file"))) 2330 (or type "MIME file")))
2261 (insert tag-string "\n") 2331 (insert tag-string "\n")
2262 (setq end (1- (point))) 2332 (setq end (1- (point)))
2263 ;; attach default filename for recipient if currently
2264 ;; non-MIME. if already MIME'd don't do this because it
2265 ;; would override any content-disposition header already in
2266 ;; the attachment.
2267 (if (and (stringp object) (not mimed)) 2333 (if (and (stringp object) (not mimed))
2268 (progn 2334 (progn
2269 (if (or (vm-mime-types-match "application" type) 2335 (if (or (vm-mime-types-match "application" type)
2270 (vm-mime-types-match "model" type)) 2336 (vm-mime-types-match "model" type))
2271 (setq disposition (list "attachment")) 2337 (setq disposition (list "attachment"))
2272 (setq disposition (list "inline"))) 2338 (setq disposition (list "inline")))
2273 (setq disposition (nconc disposition 2339 (setq disposition (nconc disposition
2274 (list 2340 (list
2275 (concat "filename=\"" 2341 (concat "filename=\""
2276 (file-name-nondirectory object) 2342 (file-name-nondirectory object)
2277 "\"")))))) 2343 "\"")))))
2344 (setq disposition (list "unspecified")))
2278 (cond ((vm-fsfemacs-19-p) 2345 (cond ((vm-fsfemacs-19-p)
2279 (put-text-property start end 'front-sticky nil) 2346 (put-text-property start end 'front-sticky nil)
2280 (put-text-property start end 'rear-nonsticky t) 2347 (put-text-property start end 'rear-nonsticky t)
2281 (put-text-property start end 'intangible object) 2348 ;; can't be intangible because menu clicking at a position needs
2349 ;; to set point inside the tag so that a command can access the
2350 ;; text properties there.
2351 ;; (put-text-property start end 'intangible object)
2282 (put-text-property start end 'face vm-mime-button-face) 2352 (put-text-property start end 'face vm-mime-button-face)
2283 (put-text-property start end 'vm-mime-type type) 2353 (put-text-property start end 'vm-mime-type type)
2284 (put-text-property start end 'vm-mime-object object) 2354 (put-text-property start end 'vm-mime-object object)
2285 (put-text-property start end 'vm-mime-parameters params) 2355 (put-text-property start end 'vm-mime-parameters params)
2286 (put-text-property start end 'vm-mime-description description) 2356 (put-text-property start end 'vm-mime-description description)
2290 ((fboundp 'make-extent) 2360 ((fboundp 'make-extent)
2291 (setq e (make-extent start end)) 2361 (setq e (make-extent start end))
2292 (set-extent-property e 'start-open t) 2362 (set-extent-property e 'start-open t)
2293 (set-extent-property e 'face vm-mime-button-face) 2363 (set-extent-property e 'face vm-mime-button-face)
2294 (vm-set-extent-property e 'duplicable t) 2364 (vm-set-extent-property e 'duplicable t)
2365 (let ((keymap (make-sparse-keymap)))
2366 (if vm-popup-menu-on-mouse-3
2367 (define-key keymap 'button3
2368 'vm-menu-popup-content-disposition-menu))
2369 (vm-set-extent-property e 'keymap keymap)
2370 (set-extent-property e 'balloon-help 'vm-mouse-3-help))
2295 (vm-set-extent-property e 'vm-mime-type type) 2371 (vm-set-extent-property e 'vm-mime-type type)
2296 (vm-set-extent-property e 'vm-mime-object object) 2372 (vm-set-extent-property e 'vm-mime-object object)
2297 (vm-set-extent-property e 'vm-mime-parameters params) 2373 (vm-set-extent-property e 'vm-mime-parameters params)
2298 (vm-set-extent-property e 'vm-mime-description description) 2374 (vm-set-extent-property e 'vm-mime-description description)
2299 (vm-set-extent-property e 'vm-mime-disposition disposition) 2375 (vm-set-extent-property e 'vm-mime-disposition disposition)
2300 (vm-set-extent-property e 'vm-mime-encoded mimed))))) 2376 (vm-set-extent-property e 'vm-mime-encoded mimed)))))
2377
2378 (defun vm-mime-attachment-disposition-at-point ()
2379 (cond ((vm-fsfemacs-19-p)
2380 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
2381 (intern (car disp))))
2382 ((vm-xemacs-p)
2383 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
2384 (disp (extent-property e 'vm-mime-disposition)))
2385 (intern (car disp))))))
2386
2387 (defun vm-mime-set-attachment-disposition-at-point (sym)
2388 (cond ((vm-fsfemacs-19-p)
2389 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
2390 (setcar disp (symbol-name sym))))
2391 ((vm-xemacs-p)
2392 (let* ((e (extent-at (point) nil 'vm-mime-disposition))
2393 (disp (extent-property e 'vm-mime-disposition)))
2394 (setcar disp (symbol-name sym))))))
2301 2395
2302 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end 2396 (defun vm-disallow-overlay-endpoint-insertion (overlay after start end
2303 &optional old-size) 2397 &optional old-size)
2304 (cond ((null after) nil) 2398 (cond ((null after) nil)
2305 ((= start (overlay-start overlay)) 2399 ((= start (overlay-start overlay))
2358 (goto-char (point-min)) 2452 (goto-char (point-min))
2359 (if (re-search-forward "^$" nil t) 2453 (if (re-search-forward "^$" nil t)
2360 (replace-match mail-header-separator t t)))) 2454 (replace-match mail-header-separator t t))))
2361 2455
2362 (defun vm-mime-transfer-encode-region (encoding beg end crlf) 2456 (defun vm-mime-transfer-encode-region (encoding beg end crlf)
2363 (let ((case-fold-search t)) 2457 (let ((case-fold-search t)
2458 (armor-from (and vm-mime-composition-armor-from-lines
2459 (let ((case-fold-search nil))
2460 (save-excursion
2461 (goto-char beg)
2462 (re-search-forward "^From " nil t))))))
2364 (cond ((string-match "^binary$" encoding) 2463 (cond ((string-match "^binary$" encoding)
2365 (vm-mime-base64-encode-region beg end crlf) 2464 (vm-mime-base64-encode-region beg end crlf)
2366 (setq encoding "base64")) 2465 (setq encoding "base64"))
2367 ((string-match "^7bit$" encoding) t) 2466 ((and (not armor-from) (string-match "^7bit$" encoding)) t)
2368 ((string-match "^base64$" encoding) t) 2467 ((string-match "^base64$" encoding) t)
2369 ((string-match "^quoted-printable$" encoding) t) 2468 ((string-match "^quoted-printable$" encoding) t)
2370 ;; must be 8bit
2371 ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) 2469 ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable)
2372 (vm-mime-qp-encode-region beg end) 2470 (vm-mime-qp-encode-region beg end nil armor-from)
2373 (setq encoding "quoted-printable")) 2471 (setq encoding "quoted-printable"))
2374 ((eq vm-mime-8bit-text-transfer-encoding 'base64) 2472 ((eq vm-mime-8bit-text-transfer-encoding 'base64)
2375 (vm-mime-base64-encode-region beg end crlf) 2473 (vm-mime-base64-encode-region beg end crlf)
2376 (setq encoding "base64")) 2474 (setq encoding "base64"))
2377 ((eq vm-mime-8bit-text-transfer-encoding 'send) t)) 2475 (armor-from (vm-mime-qp-encode-region beg end nil armor-from))
2476 ((eq vm-mime-8bit-text-transfer-encoding '8bit) t))
2378 encoding )) 2477 encoding ))
2379 2478
2380 (defun vm-mime-transfer-encode-layout (layout) 2479 (defun vm-mime-transfer-encode-layout (layout)
2381 (if (vm-mime-text-type-p layout) 2480 (if (vm-mime-text-type-p layout)
2382 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) 2481 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
2473 (goto-char (vm-extent-start-position e)) 2572 (goto-char (vm-extent-start-position e))
2474 (narrow-to-region (point) (point)) 2573 (narrow-to-region (point) (point))
2475 (setq object (vm-extent-property e 'vm-mime-object)) 2574 (setq object (vm-extent-property e 'vm-mime-object))
2476 ;; insert the object 2575 ;; insert the object
2477 (cond ((bufferp object) 2576 (cond ((bufferp object)
2478 (insert-buffer-substring object)) 2577 (if (vm-xemacs-p)
2578 (insert-buffer-substring object)
2579 ;; as of FSF Emacs 19.34, even with the hooks
2580 ;; we've attached to the attachment overlays,
2581 ;; text STILL can be inserted into them when
2582 ;; font-lock is enabled. Explaining why is
2583 ;; beyond the scope of this comment and I
2584 ;; don't know the answer anyway. This works
2585 ;; to prevent it.
2586 (insert-before-markers " ")
2587 (forward-char -1)
2588 (insert-buffer-substring object)
2589 (delete-char 1)))
2479 ((stringp object) 2590 ((stringp object)
2480 (let ((overridding-file-coding-system 'no-conversion)) 2591 (let ((overridding-file-coding-system 'no-conversion))
2481 (insert-file-contents-literally object)))) 2592 (insert-file-contents-literally object))))
2482 ;; gather information about the object from the extent. 2593 ;; gather information about the object from the extent.
2483 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) 2594 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded))
2487 type (or (vm-extent-property e 'vm-mime-type) 2598 type (or (vm-extent-property e 'vm-mime-type)
2488 (car (vm-mm-layout-type layout))) 2599 (car (vm-mm-layout-type layout)))
2489 params (or (vm-extent-property e 'vm-mime-parameters) 2600 params (or (vm-extent-property e 'vm-mime-parameters)
2490 (cdr (vm-mm-layout-qtype layout))) 2601 (cdr (vm-mm-layout-qtype layout)))
2491 description (vm-extent-property e 'vm-mime-description) 2602 description (vm-extent-property e 'vm-mime-description)
2492 disposition (or (vm-extent-property e 'vm-mime-disposition) 2603 disposition
2493 (vm-mm-layout-qdisposition layout))) 2604 (if (not
2605 (equal
2606 (car (vm-extent-property e 'vm-mime-disposition))
2607 "unspecified"))
2608 (vm-extent-property e 'vm-mime-disposition)
2609 (vm-mm-layout-qdisposition layout)))
2494 (setq type (vm-extent-property e 'vm-mime-type) 2610 (setq type (vm-extent-property e 'vm-mime-type)
2495 params (vm-extent-property e 'vm-mime-parameters) 2611 params (vm-extent-property e 'vm-mime-parameters)
2496 description (vm-extent-property e 'vm-mime-description) 2612 description (vm-extent-property e 'vm-mime-description)
2497 disposition (vm-extent-property e 'vm-mime-disposition))) 2613 disposition
2614 (if (not (equal
2615 (car (vm-extent-property e 'vm-mime-disposition))
2616 "unspecified"))
2617 (vm-extent-property e 'vm-mime-disposition)
2618 nil)))
2498 (cond ((vm-mime-types-match "text" type) 2619 (cond ((vm-mime-types-match "text" type)
2499 (setq encoding 2620 (setq encoding
2500 (vm-determine-proper-content-transfer-encoding 2621 (vm-determine-proper-content-transfer-encoding
2501 (if already-mimed 2622 (if already-mimed
2502 (vm-mm-layout-body-start layout) 2623 (vm-mm-layout-body-start layout)
2509 (point-min)) 2630 (point-min))
2510 (point-max) 2631 (point-max)
2511 t)) 2632 t))
2512 (setq 8bit (or 8bit (equal encoding "8bit")))) 2633 (setq 8bit (or 8bit (equal encoding "8bit"))))
2513 ((or (vm-mime-types-match "message/rfc822" type) 2634 ((or (vm-mime-types-match "message/rfc822" type)
2635 (vm-mime-types-match "message/news" type)
2514 (vm-mime-types-match "multipart" type)) 2636 (vm-mime-types-match "multipart" type))
2515 (setq opoint-min (point-min)) 2637 (setq opoint-min (point-min))
2516 (if (not already-mimed) 2638 (if (not already-mimed)
2517 (setq layout (vm-mime-parse-entity 2639 (setq layout (vm-mime-parse-entity
2518 nil (list "text/plain" "charset=us-ascii") 2640 nil (list "text/plain" "charset=us-ascii")
2589 ";\n\t"))) 2711 ";\n\t")))
2590 (insert "\n"))) 2712 (insert "\n")))
2591 (insert "Content-Transfer-Encoding: " encoding "\n\n")) 2713 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
2592 (goto-char (point-max)) 2714 (goto-char (point-max))
2593 (widen) 2715 (widen)
2716 (save-excursion
2717 (goto-char (vm-extent-start-position e))
2718 (vm-assert (looking-at "\\[ATTACHMENT")))
2594 (delete-region (vm-extent-start-position e) 2719 (delete-region (vm-extent-start-position e)
2595 (vm-extent-end-position e)) 2720 (vm-extent-end-position e))
2596 (vm-detach-extent e) 2721 (vm-detach-extent e)
2597 (if (looking-at "\n") 2722 (if (looking-at "\n")
2598 (delete-char 1)) 2723 (delete-char 1))