Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 118:7d55a9ba150c r20-1b11

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b11
author cvs
date Mon, 13 Aug 2007 09:24:17 +0200
parents 9f59509498e1
children cca96a509cfe
comparison
equal deleted inserted replaced
117:578fd4947a72 118:7d55a9ba150c
342 1 nil work-buffer) 342 1 nil work-buffer)
343 (forward-char 2)) 343 (forward-char 2))
344 ((looking-at "\n") ; soft line break 344 ((looking-at "\n") ; soft line break
345 (forward-char)) 345 (forward-char))
346 ((looking-at "\r") 346 ((looking-at "\r")
347 ;; assume the user's goatfucking 347 ;; assume the user's goatloving
348 ;; delivery software didn't convert 348 ;; delivery software didn't convert
349 ;; from Internet's CRLF newline 349 ;; from Internet's CRLF newline
350 ;; convention to the local LF 350 ;; convention to the local LF
351 ;; convention. 351 ;; convention.
352 (forward-char)) 352 (forward-char))
524 (if (and vm-display-using-mime 524 (if (and vm-display-using-mime
525 (text-property-any 0 (length string) 'vm-string t string)) 525 (text-property-any 0 (length string) 'vm-string t string))
526 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words) 526 (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words)
527 string )) 527 string ))
528 528
529 (defun vm-mime-parse-content-header (string &optional sepchar keep-quotes) 529 (fset 'vm-mime-parse-content-header 'vm-parse-structured-header)
530 (if (null string)
531 ()
532 (let ((work-buffer nil))
533 (save-excursion
534 (unwind-protect
535 (let ((list nil)
536 (nonspecials "^\"\\( \t\n\r\f")
537 start s char sp+sepchar)
538 (if sepchar
539 (setq nonspecials (concat nonspecials (list sepchar))
540 sp+sepchar (concat "\t\f\n\r " (list sepchar))))
541 (setq work-buffer (generate-new-buffer "*vm-work*"))
542 (buffer-disable-undo work-buffer)
543 (set-buffer work-buffer)
544 (insert string)
545 (goto-char (point-min))
546 (skip-chars-forward "\t\f\n\r ")
547 (setq start (point))
548 (while (not (eobp))
549 (skip-chars-forward nonspecials)
550 (setq char (following-char))
551 (cond ((looking-at "[ \t\n\r\f]")
552 (delete-char 1))
553 ((= char ?\\)
554 (forward-char 1)
555 (if (not (eobp))
556 (forward-char 1)))
557 ((and sepchar (= char sepchar))
558 (setq s (buffer-substring start (point)))
559 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
560 (not (string= s "")))
561 (setq list (cons s list)))
562 (skip-chars-forward sp+sepchar)
563 (setq start (point)))
564 ((looking-at " \t\n\r\f")
565 (skip-chars-forward " \t\n\r\f"))
566 ((= char ?\")
567 (let ((done nil))
568 (if keep-quotes
569 (forward-char 1)
570 (delete-char 1))
571 (while (not done)
572 (if (null (re-search-forward "[\\\"]" nil t))
573 (setq done t)
574 (setq char (char-after (1- (point))))
575 (cond ((char-equal char ?\\)
576 (delete-char -1)
577 (if (eobp)
578 (setq done t)
579 (forward-char 1)))
580 (t (if (not keep-quotes)
581 (delete-char -1))
582 (setq done t)))))))
583 ((= char ?\()
584 (let ((done nil)
585 (pos (point))
586 (parens 1))
587 (forward-char 1)
588 (while (not done)
589 (if (null (re-search-forward "[\\()]" nil t))
590 (setq done t)
591 (setq char (char-after (1- (point))))
592 (cond ((char-equal char ?\\)
593 (if (eobp)
594 (setq done t)
595 (forward-char 1)))
596 ((char-equal char ?\()
597 (setq parens (1+ parens)))
598 (t
599 (setq parens (1- parens)
600 done (zerop parens))))))
601 (delete-region pos (point))))))
602 (setq s (buffer-substring start (point)))
603 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
604 (not (string= s "")))
605 (setq list (cons s list)))
606 (nreverse list))
607 (and work-buffer (kill-buffer work-buffer)))))))
608 530
609 (defun vm-mime-get-header-contents (header-name-regexp) 531 (defun vm-mime-get-header-contents (header-name-regexp)
610 (let ((contents nil) 532 (let ((contents nil)
611 regexp) 533 regexp)
612 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) 534 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
1585 (list this-command) '(vm-mode startup))) 1507 (list this-command) '(vm-mode startup)))
1586 t ) 1508 t )
1587 (fset 'vm-mime-display-button-multipart/digest 1509 (fset 'vm-mime-display-button-multipart/digest
1588 'vm-mime-display-internal-multipart/digest) 1510 'vm-mime-display-internal-multipart/digest)
1589 1511
1512 (defun vm-mime-display-button-message/rfc822 (layout)
1513 (let ((buffer-read-only nil))
1514 (vm-mime-insert-button
1515 (format "%-35.35s [%s to display]"
1516 (vm-mime-layout-description layout)
1517 (if (vm-mouse-support-possible-p)
1518 "Click mouse-2"
1519 "Press RETURN"))
1520 (function
1521 (lambda (layout)
1522 (save-excursion
1523 (vm-mime-display-internal-message/rfc822 layout))))
1524 layout nil)))
1525 (fset 'vm-mime-display-button-message/news
1526 'vm-mime-display-button-message/rfc822)
1527
1590 (defun vm-mime-display-internal-message/rfc822 (layout) 1528 (defun vm-mime-display-internal-message/rfc822 (layout)
1591 (if (vectorp layout) 1529 (if (vectorp layout)
1592 (let ((buffer-read-only nil)) 1530 (vm-mime-display-internal-text/plain layout)
1593 (vm-mime-insert-button
1594 (format "%-35.35s [%s to display]"
1595 (vm-mime-layout-description layout)
1596 (if (vm-mouse-support-possible-p)
1597 "Click mouse-2"
1598 "Press RETURN"))
1599 (function
1600 (lambda (layout)
1601 (save-excursion
1602 (vm-mime-display-internal-message/rfc822 layout))))
1603 layout nil))
1604 (goto-char (vm-extent-start-position layout)) 1531 (goto-char (vm-extent-start-position layout))
1605 (setq layout (vm-extent-property layout 'vm-mime-layout)) 1532 (setq layout (vm-extent-property layout 'vm-mime-layout))
1606 (set-buffer (generate-new-buffer 1533 (set-buffer (generate-new-buffer
1607 (format "message from %s/%s" 1534 (format "message from %s/%s"
1608 (buffer-name vm-mail-buffer) 1535 (buffer-name vm-mail-buffer)
1617 ;; temp buffer, don't offer to save it. 1544 ;; temp buffer, don't offer to save it.
1618 (setq buffer-offer-save nil) 1545 (setq buffer-offer-save nil)
1619 (vm-display (or vm-presentation-buffer (current-buffer)) t 1546 (vm-display (or vm-presentation-buffer (current-buffer)) t
1620 (list this-command) '(vm-mode startup))) 1547 (list this-command) '(vm-mode startup)))
1621 t ) 1548 t )
1622 (fset 'vm-mime-display-button-message/rfc822
1623 'vm-mime-display-internal-message/rfc822)
1624 (fset 'vm-mime-display-internal-message/news 1549 (fset 'vm-mime-display-internal-message/news
1625 'vm-mime-display-internal-message/rfc822) 1550 'vm-mime-display-internal-message/rfc822)
1626 1551
1627 (defun vm-mime-display-internal-message/partial (layout) 1552 (defun vm-mime-display-internal-message/partial (layout)
1628 (if (vectorp layout) 1553 (if (vectorp layout)
1875 ;; for the karking compiler 1800 ;; for the karking compiler
1876 (defvar vm-menu-mime-dispose-menu) 1801 (defvar vm-menu-mime-dispose-menu)
1877 1802
1878 (defun vm-mime-set-extent-glyph-for-layout (e layout) 1803 (defun vm-mime-set-extent-glyph-for-layout (e layout)
1879 (if (and (vm-xemacs-p) (fboundp 'make-glyph) 1804 (if (and (vm-xemacs-p) (fboundp 'make-glyph)
1880 (eq (device-type) 'x) (> (device-bitplanes) 15)) 1805 (eq (device-type) 'x) (> (device-bitplanes) 7))
1881 (let ((type (car (vm-mm-layout-type layout))) 1806 (let ((type (car (vm-mm-layout-type layout)))
1882 (dir vm-image-directory) 1807 (dir vm-image-directory)
1883 glyph) 1808 (colorful (> (device-bitplanes) 15))
1884 (setq glyph 1809 (tuples
1885 (cond ((vm-mime-types-match "text" type) 1810 '(("text" "document-simple.xpm" "document-colorful.xpm")
1886 (make-glyph (vector 1811 ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm")
1887 'xpm ':file 1812 ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm")
1888 (expand-file-name "document.xpm" dir)))) 1813 ("video" "film-simple.xpm" "film-colorful.xpm")
1889 ((vm-mime-types-match "image" type) 1814 ("message" "message-simple.xpm" "message-colorful.xpm")
1890 (make-glyph (vector 1815 ("application" "gear-simple.xpm" "gear-colorful.xpm")
1891 'gif ':file 1816 ("multipart" "stuffed_box-simple.xpm"
1892 (expand-file-name "mona_stamp.gif" dir)))) 1817 "stuffed_box-colorful.xpm")))
1893 ((vm-mime-types-match "audio" type) 1818 glyph file sym p)
1894 (make-glyph (vector 1819 (setq file (catch 'done
1895 'xpm ':file 1820 (while tuples
1896 (expand-file-name "audio_stamp.xpm" dir)))) 1821 (if (vm-mime-types-match (car (car tuples)) type)
1897 ((vm-mime-types-match "video" type) 1822 (throw 'done (car tuples))
1898 (make-glyph (vector 1823 (setq tuples (cdr tuples))))
1899 'xpm ':file 1824 nil)
1900 (expand-file-name "film.xpm" dir)))) 1825 file (and file (if colorful (nth 1 file) (nth 2 file)))
1901 ((vm-mime-types-match "message" type) 1826 sym (and file (intern file vm-image-obarray))
1902 (make-glyph (vector 1827 glyph (and sym (boundp sym) (symbol-value sym))
1903 'xpm ':file 1828 glyph (or glyph (not file)
1904 (expand-file-name "message.xpm" dir)))) 1829 (make-glyph
1905 ((vm-mime-types-match "application" type) 1830 (vector 'autodetect
1906 (make-glyph (vector 1831 ':data (expand-file-name file dir)))))
1907 'xpm ':file 1832 (and sym (not (boundp sym)) (set sym glyph))
1908 (expand-file-name "gear.xpm" dir))))
1909 ((vm-mime-types-match "multipart" type)
1910 (make-glyph (vector
1911 'xpm ':file
1912 (expand-file-name "stuffed_box.xpm" dir))))
1913 (t nil)))
1914 (and glyph (set-extent-begin-glyph e glyph))))) 1833 (and glyph (set-extent-begin-glyph e glyph)))))
1915 1834
1916 (defun vm-mime-insert-button (caption action layout disposable) 1835 (defun vm-mime-insert-button (caption action layout disposable)
1917 (let ((start (point)) e 1836 (let ((start (point)) e
1918 (keymap (make-sparse-keymap)) 1837 (keymap (make-sparse-keymap))
2348 (put-text-property start end 'vm-mime-object object)) 2267 (put-text-property start end 'vm-mime-object object))
2349 ((fboundp 'make-extent) 2268 ((fboundp 'make-extent)
2350 (setq e (make-extent start end)) 2269 (setq e (make-extent start end))
2351 (set-extent-property e 'start-open t) 2270 (set-extent-property e 'start-open t)
2352 (set-extent-property e 'face vm-mime-button-face) 2271 (set-extent-property e 'face vm-mime-button-face)
2353 (vm-set-extent-property e 'duplicable t) 2272 (set-extent-property e 'duplicable t)
2354 (let ((keymap (make-sparse-keymap))) 2273 (let ((keymap (make-sparse-keymap)))
2355 (if vm-popup-menu-on-mouse-3 2274 (if vm-popup-menu-on-mouse-3
2356 (define-key keymap 'button3 2275 (define-key keymap 'button3
2357 'vm-menu-popup-content-disposition-menu)) 2276 'vm-menu-popup-content-disposition-menu))
2358 (vm-set-extent-property e 'keymap keymap) 2277 (set-extent-property e 'keymap keymap)
2359 (set-extent-property e 'balloon-help 'vm-mouse-3-help)) 2278 (set-extent-property e 'balloon-help 'vm-mouse-3-help))
2360 (vm-set-extent-property e 'vm-mime-type type) 2279 (set-extent-property e 'vm-mime-type type)
2361 (vm-set-extent-property e 'vm-mime-object object) 2280 (set-extent-property e 'vm-mime-object object)
2362 (vm-set-extent-property e 'vm-mime-parameters params) 2281 (set-extent-property e 'vm-mime-parameters params)
2363 (vm-set-extent-property e 'vm-mime-description description) 2282 (set-extent-property e 'vm-mime-description description)
2364 (vm-set-extent-property e 'vm-mime-disposition disposition) 2283 (set-extent-property e 'vm-mime-disposition disposition)
2365 (vm-set-extent-property e 'vm-mime-encoded mimed))))) 2284 (set-extent-property e 'vm-mime-encoded mimed)))))
2366 2285
2367 (defun vm-mime-attachment-disposition-at-point () 2286 (defun vm-mime-attachment-disposition-at-point ()
2368 (cond ((vm-fsfemacs-19-p) 2287 (cond ((vm-fsfemacs-19-p)
2369 (let ((disp (get-text-property (point) 'vm-mime-disposition))) 2288 (let ((disp (get-text-property (point) 'vm-mime-disposition)))
2370 (intern (car disp)))) 2289 (intern (car disp))))
2475 (vm-mm-layout-body-start layout) 2394 (vm-mm-layout-body-start layout)
2476 (vm-mm-layout-body-end layout) 2395 (vm-mm-layout-body-end layout)
2477 nil))) 2396 nil)))
2478 2397
2479 (defun vm-mime-encode-composition () 2398 (defun vm-mime-encode-composition ()
2480 "MIME encode the current buffer. 2399 "MIME encode the current mail composition buffer.
2481 Attachment tags added to the buffer with vm-mime-attach-file are expanded 2400 Attachment tags added to the buffer with vm-mime-attach-file are expanded
2482 and the approriate content-type and boundary markup information is added." 2401 and the approriate content-type and boundary markup information is added."
2483 (interactive) 2402 (interactive)
2403 (cond ((vm-xemacs-mule-p)
2404 (vm-mime-xemacs-encode-composition))
2405 ((vm-xemacs-p)
2406 (vm-mime-xemacs-encode-composition))
2407 ((vm-fsfemacs-19-p)
2408 (vm-mime-fsfemacs-encode-composition))
2409 (t
2410 (error "don't know how to MIME encode composition for %s"
2411 (emacs-version)))))
2412
2413 (defun vm-mime-xemacs-encode-composition ()
2484 (save-restriction 2414 (save-restriction
2485 (widen) 2415 (widen)
2486 (if (not (eq major-mode 'mail-mode)) 2416 (if (not (eq major-mode 'mail-mode))
2487 (error "Command must be used in a VM Mail mode buffer.")) 2417 (error "Command must be used in a VM Mail mode buffer."))
2488 (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) 2418 (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
2492 (boundary-positions nil) 2422 (boundary-positions nil)
2493 already-mimed layout e e-list boundary 2423 already-mimed layout e e-list boundary
2494 type encoding charset params description disposition object 2424 type encoding charset params description disposition object
2495 opoint-min) 2425 opoint-min)
2496 (mail-text) 2426 (mail-text)
2497 (setq e-list (if (fboundp 'extent-list) 2427 (setq e-list (extent-list nil (point) (point-max))
2498 (extent-list nil (point) (point-max))
2499 (vm-mime-fake-attachment-overlays (point) (point-max)))
2500 e-list (vm-delete (function 2428 e-list (vm-delete (function
2501 (lambda (e) 2429 (lambda (e)
2502 (vm-extent-property e 'vm-mime-object))) 2430 (extent-property e 'vm-mime-object)))
2503 e-list t) 2431 e-list t)
2504 e-list (sort e-list (function 2432 e-list (sort e-list (function
2505 (lambda (e1 e2) 2433 (lambda (e1 e2)
2506 (< (vm-extent-end-position e1) 2434 (< (extent-end-position e1)
2507 (vm-extent-end-position e2)))))) 2435 (extent-end-position e2))))))
2508 ;; If there's just one attachment and no other readable 2436 ;; If there's just one attachment and no other readable
2509 ;; text in the buffer then make the message type just be 2437 ;; text in the buffer then make the message type just be
2510 ;; the attachment type rather than sending a multipart 2438 ;; the attachment type rather than sending a multipart
2511 ;; message with one attachment 2439 ;; message with one attachment
2512 (setq just-one (and (= (length e-list) 1) 2440 (setq just-one (and (= (length e-list) 1)
2513 (looking-at "[ \t\n]*") 2441 (looking-at "[ \t\n]*")
2514 (= (match-end 0) 2442 (= (match-end 0)
2515 (vm-extent-start-position (car e-list))) 2443 (extent-start-position (car e-list)))
2516 (save-excursion 2444 (save-excursion
2517 (goto-char (vm-extent-end-position (car e-list))) 2445 (goto-char (extent-end-position (car e-list)))
2518 (looking-at "[ \t\n]*\\'")))) 2446 (looking-at "[ \t\n]*\\'"))))
2519 (if (null e-list) 2447 (if (null e-list)
2520 (progn 2448 (progn
2521 (narrow-to-region (point) (point-max)) 2449 (narrow-to-region (point) (point-max))
2522 (setq charset (vm-determine-proper-charset (point-min) 2450 (setq charset (vm-determine-proper-charset (point-min)
2540 (insert "Content-Type: text/plain; charset=" charset "\n") 2468 (insert "Content-Type: text/plain; charset=" charset "\n")
2541 (insert "Content-Transfer-Encoding: " encoding "\n") 2469 (insert "Content-Transfer-Encoding: " encoding "\n")
2542 (vm-add-mail-mode-header-separator)) 2470 (vm-add-mail-mode-header-separator))
2543 (while e-list 2471 (while e-list
2544 (setq e (car e-list)) 2472 (setq e (car e-list))
2545 (if (or just-one (= (point) (vm-extent-start-position e))) 2473 (if (or just-one (= (point) (extent-start-position e)))
2546 nil 2474 nil
2547 (narrow-to-region (point) (vm-extent-start-position e)) 2475 (narrow-to-region (point) (extent-start-position e))
2548 (setq charset (vm-determine-proper-charset (point-min) 2476 (setq charset (vm-determine-proper-charset (point-min)
2549 (point-max))) 2477 (point-max)))
2550 (setq encoding (vm-determine-proper-content-transfer-encoding 2478 (setq encoding (vm-determine-proper-content-transfer-encoding
2551 (point-min) 2479 (point-min)
2552 (point-max)) 2480 (point-max))
2556 t)) 2484 t))
2557 (setq boundary-positions (cons (point-marker) boundary-positions)) 2485 (setq boundary-positions (cons (point-marker) boundary-positions))
2558 (insert "Content-Type: text/plain; charset=" charset "\n") 2486 (insert "Content-Type: text/plain; charset=" charset "\n")
2559 (insert "Content-Transfer-Encoding: " encoding "\n\n") 2487 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2560 (widen)) 2488 (widen))
2561 (goto-char (vm-extent-start-position e)) 2489 (goto-char (extent-start-position e))
2562 (narrow-to-region (point) (point)) 2490 (narrow-to-region (point) (point))
2563 (setq object (vm-extent-property e 'vm-mime-object)) 2491 (setq object (extent-property e 'vm-mime-object))
2564 ;; insert the object 2492 ;; insert the object
2565 (cond ((bufferp object) 2493 (cond ((bufferp object)
2566 (if (vm-xemacs-p) 2494 (insert-buffer-substring object))
2567 (insert-buffer-substring object)
2568 ;; as of FSF Emacs 19.34, even with the hooks
2569 ;; we've attached to the attachment overlays,
2570 ;; text STILL can be inserted into them when
2571 ;; font-lock is enabled. Explaining why is
2572 ;; beyond the scope of this comment and I
2573 ;; don't know the answer anyway. This works
2574 ;; to prevent it.
2575 (insert-before-markers " ")
2576 (forward-char -1)
2577 (insert-buffer-substring object)
2578 (delete-char 1)))
2579 ((stringp object) 2495 ((stringp object)
2580 (let ((coding-system-for-read 'no-conversion)) 2496 (let ((coding-system-for-read 'no-conversion))
2581 (if (vm-xemacs-p) 2497 (insert-file-contents-literally object))))
2582 (insert-file-contents-literally object)
2583 (insert-before-markers " ")
2584 (forward-char -1)
2585 (insert-file-contents-literally object)
2586 (goto-char (point-max))
2587 (delete-char -1)))))
2588 ;; gather information about the object from the extent. 2498 ;; gather information about the object from the extent.
2589 (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) 2499 (if (setq already-mimed (extent-property e 'vm-mime-encoded))
2590 (setq layout (vm-mime-parse-entity 2500 (setq layout (vm-mime-parse-entity
2591 nil (list "text/plain" "charset=us-ascii") 2501 nil (list "text/plain" "charset=us-ascii")
2592 "7bit") 2502 "7bit")
2593 type (or (vm-extent-property e 'vm-mime-type) 2503 type (or (extent-property e 'vm-mime-type)
2594 (car (vm-mm-layout-type layout))) 2504 (car (vm-mm-layout-type layout)))
2595 params (or (vm-extent-property e 'vm-mime-parameters) 2505 params (or (extent-property e 'vm-mime-parameters)
2596 (cdr (vm-mm-layout-qtype layout))) 2506 (cdr (vm-mm-layout-qtype layout)))
2597 description (vm-extent-property e 'vm-mime-description) 2507 description (extent-property e 'vm-mime-description)
2598 disposition 2508 disposition
2599 (if (not 2509 (if (not
2600 (equal 2510 (equal
2601 (car (vm-extent-property e 'vm-mime-disposition)) 2511 (car (extent-property e 'vm-mime-disposition))
2602 "unspecified")) 2512 "unspecified"))
2603 (vm-extent-property e 'vm-mime-disposition) 2513 (extent-property e 'vm-mime-disposition)
2604 (vm-mm-layout-qdisposition layout))) 2514 (vm-mm-layout-qdisposition layout)))
2605 (setq type (vm-extent-property e 'vm-mime-type) 2515 (setq type (extent-property e 'vm-mime-type)
2606 params (vm-extent-property e 'vm-mime-parameters) 2516 params (extent-property e 'vm-mime-parameters)
2607 description (vm-extent-property e 'vm-mime-description) 2517 description (extent-property e 'vm-mime-description)
2608 disposition 2518 disposition
2609 (if (not (equal 2519 (if (not (equal
2610 (car (vm-extent-property e 'vm-mime-disposition)) 2520 (car (extent-property e 'vm-mime-disposition))
2611 "unspecified")) 2521 "unspecified"))
2612 (vm-extent-property e 'vm-mime-disposition) 2522 (extent-property e 'vm-mime-disposition)
2613 nil))) 2523 nil)))
2614 (cond ((vm-mime-types-match "text" type) 2524 (cond ((vm-mime-types-match "text" type)
2615 (setq encoding 2525 (setq encoding
2616 (vm-determine-proper-content-transfer-encoding 2526 (vm-determine-proper-content-transfer-encoding
2617 (if already-mimed 2527 (if already-mimed
2707 (insert "\n"))) 2617 (insert "\n")))
2708 (insert "Content-Transfer-Encoding: " encoding "\n\n")) 2618 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
2709 (goto-char (point-max)) 2619 (goto-char (point-max))
2710 (widen) 2620 (widen)
2711 (save-excursion 2621 (save-excursion
2712 (goto-char (vm-extent-start-position e)) 2622 (goto-char (extent-start-position e))
2713 (vm-assert (looking-at "\\[ATTACHMENT"))) 2623 (vm-assert (looking-at "\\[ATTACHMENT")))
2714 (delete-region (vm-extent-start-position e) 2624 (delete-region (extent-start-position e)
2715 (vm-extent-end-position e)) 2625 (extent-end-position e))
2716 (vm-detach-extent e) 2626 (detach-extent e)
2717 (if (looking-at "\n") 2627 (if (looking-at "\n")
2718 (delete-char 1)) 2628 (delete-char 1))
2719 (setq e-list (cdr e-list))) 2629 (setq e-list (cdr e-list)))
2720 ;; handle the remaining chunk of text after the last 2630 ;; handle the remaining chunk of text after the last
2721 ;; extent, if any. 2631 ;; extent, if any.
2800 (insert "Content-Transfer-Encoding: " encoding "\n") 2710 (insert "Content-Transfer-Encoding: " encoding "\n")
2801 (if 8bit 2711 (if 8bit
2802 (insert "Content-Transfer-Encoding: 8bit\n") 2712 (insert "Content-Transfer-Encoding: 8bit\n")
2803 (insert "Content-Transfer-Encoding: 7bit\n"))))))) 2713 (insert "Content-Transfer-Encoding: 7bit\n")))))))
2804 2714
2715 (defun vm-mime-fsfemacs-encode-composition ()
2716 (save-restriction
2717 (widen)
2718 (if (not (eq major-mode 'mail-mode))
2719 (error "Command must be used in a VM Mail mode buffer."))
2720 (or (null (vm-mail-mode-get-header-contents "MIME-Version:"))
2721 (error "Message is already MIME encoded."))
2722 (let ((8bit nil)
2723 (just-one nil)
2724 (boundary-positions nil)
2725 already-mimed layout o o-list boundary
2726 type encoding charset params description disposition object
2727 opoint-min)
2728 (mail-text)
2729 (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max))
2730 o-list (vm-delete (function
2731 (lambda (o)
2732 (overlay-get o 'vm-mime-object)))
2733 o-list t)
2734 o-list (sort o-list (function
2735 (lambda (e1 e2)
2736 (< (overlay-end e1)
2737 (overlay-end e2))))))
2738 ;; If there's just one attachment and no other readable
2739 ;; text in the buffer then make the message type just be
2740 ;; the attachment type rather than sending a multipart
2741 ;; message with one attachment
2742 (setq just-one (and (= (length o-list) 1)
2743 (looking-at "[ \t\n]*")
2744 (= (match-end 0)
2745 (overlay-start (car o-list)))
2746 (save-excursion
2747 (goto-char (overlay-end (car o-list)))
2748 (looking-at "[ \t\n]*\\'"))))
2749 (if (null o-list)
2750 (progn
2751 (narrow-to-region (point) (point-max))
2752 (setq charset (vm-determine-proper-charset (point-min)
2753 (point-max)))
2754 (if (vm-xemacs-mule-p)
2755 (encode-coding-region (point-min) (point-max)
2756 file-coding-system))
2757 (setq encoding (vm-determine-proper-content-transfer-encoding
2758 (point-min)
2759 (point-max))
2760 encoding (vm-mime-transfer-encode-region encoding
2761 (point-min)
2762 (point-max)
2763 t))
2764 (widen)
2765 (vm-remove-mail-mode-header-separator)
2766 (goto-char (point-min))
2767 (vm-reorder-message-headers
2768 nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)")
2769 (insert "MIME-Version: 1.0\n")
2770 (insert "Content-Type: text/plain; charset=" charset "\n")
2771 (insert "Content-Transfer-Encoding: " encoding "\n")
2772 (vm-add-mail-mode-header-separator))
2773 (while o-list
2774 (setq o (car o-list))
2775 (if (or just-one (= (point) (overlay-start o)))
2776 nil
2777 (narrow-to-region (point) (overlay-start o))
2778 (setq charset (vm-determine-proper-charset (point-min)
2779 (point-max)))
2780 (setq encoding (vm-determine-proper-content-transfer-encoding
2781 (point-min)
2782 (point-max))
2783 encoding (vm-mime-transfer-encode-region encoding
2784 (point-min)
2785 (point-max)
2786 t))
2787 (setq boundary-positions (cons (point-marker) boundary-positions))
2788 (insert "Content-Type: text/plain; charset=" charset "\n")
2789 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2790 (widen))
2791 (goto-char (overlay-start o))
2792 (narrow-to-region (point) (point))
2793 (setq object (overlay-get o 'vm-mime-object))
2794 ;; insert the object
2795 (cond ((bufferp object)
2796 ;; as of FSF Emacs 19.34, even with the hooks
2797 ;; we've attached to the attachment overlays,
2798 ;; text STILL can be inserted into them when
2799 ;; font-lock is enabled. Explaining why is
2800 ;; beyond the scope of this comment and I
2801 ;; don't know the answer anyway. This works
2802 ;; to prevent it.
2803 (insert-before-markers " ")
2804 (forward-char -1)
2805 (insert-buffer-substring object)
2806 (delete-char 1))
2807 ((stringp object)
2808 (insert-before-markers " ")
2809 (forward-char -1)
2810 (insert-file-contents object)
2811 (goto-char (point-max))
2812 (delete-char -1)))
2813 ;; gather information about the object from the extent.
2814 (if (setq already-mimed (overlay-get o 'vm-mime-encoded))
2815 (setq layout (vm-mime-parse-entity
2816 nil (list "text/plain" "charset=us-ascii")
2817 "7bit")
2818 type (or (overlay-get o 'vm-mime-type)
2819 (car (vm-mm-layout-type layout)))
2820 params (or (overlay-get o 'vm-mime-parameters)
2821 (cdr (vm-mm-layout-qtype layout)))
2822 description (overlay-get o 'vm-mime-description)
2823 disposition
2824 (if (not
2825 (equal
2826 (car (overlay-get o 'vm-mime-disposition))
2827 "unspecified"))
2828 (overlay-get o 'vm-mime-disposition)
2829 (vm-mm-layout-qdisposition layout)))
2830 (setq type (overlay-get o 'vm-mime-type)
2831 params (overlay-get o 'vm-mime-parameters)
2832 description (overlay-get o 'vm-mime-description)
2833 disposition
2834 (if (not (equal
2835 (car (overlay-get o 'vm-mime-disposition))
2836 "unspecified"))
2837 (overlay-get o 'vm-mime-disposition)
2838 nil)))
2839 (cond ((vm-mime-types-match "text" type)
2840 (setq encoding
2841 (vm-determine-proper-content-transfer-encoding
2842 (if already-mimed
2843 (vm-mm-layout-body-start layout)
2844 (point-min))
2845 (point-max))
2846 encoding (vm-mime-transfer-encode-region
2847 encoding
2848 (if already-mimed
2849 (vm-mm-layout-body-start layout)
2850 (point-min))
2851 (point-max)
2852 t))
2853 (setq 8bit (or 8bit (equal encoding "8bit"))))
2854 ((or (vm-mime-types-match "message/rfc822" type)
2855 (vm-mime-types-match "message/news" type)
2856 (vm-mime-types-match "multipart" type))
2857 (setq opoint-min (point-min))
2858 (if (not already-mimed)
2859 (setq layout (vm-mime-parse-entity
2860 nil (list "text/plain" "charset=us-ascii")
2861 "7bit")))
2862 ;; MIME messages of type "message" and
2863 ;; "multipart" are required to have a non-opaque
2864 ;; content transfer encoding. This means that
2865 ;; if the user only wants to send out 7bit data,
2866 ;; then any subpart that contains 8bit data must
2867 ;; have an opaque (qp or base64) 8->7bit
2868 ;; conversion performed on it so that the
2869 ;; enclosing entity can use an non-opqaue
2870 ;; encoding.
2871 ;;
2872 ;; message/partial requires a "7bit" encoding so
2873 ;; force 8->7 conversion in that case.
2874 (let ((vm-mime-8bit-text-transfer-encoding
2875 (if (vm-mime-types-match "message/partial" type)
2876 'quoted-printable
2877 vm-mime-8bit-text-transfer-encoding)))
2878 (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
2879 (vm-mm-layout-parts layout)))
2880 ;; now figure out a proper content trasnfer
2881 ;; encoding value for the enclosing entity.
2882 (re-search-forward "^\n" nil t)
2883 (save-restriction
2884 (narrow-to-region (point) (point-max))
2885 (setq encoding
2886 (vm-determine-proper-content-transfer-encoding
2887 (point-min)
2888 (point-max))))
2889 (setq 8bit (or 8bit (equal encoding "8bit")))
2890 (goto-char (point-max))
2891 (widen)
2892 (narrow-to-region opoint-min (point)))
2893 (t
2894 (vm-mime-base64-encode-region
2895 (if already-mimed
2896 (vm-mm-layout-body-start layout)
2897 (point-min))
2898 (point-max))
2899 (setq encoding "base64")))
2900 (if just-one
2901 nil
2902 (goto-char (point-min))
2903 (setq boundary-positions (cons (point-marker) boundary-positions))
2904 (if (not already-mimed)
2905 nil
2906 ;; trim headers
2907 (vm-reorder-message-headers
2908 nil (nconc (list "Content-Disposition:" "Content-ID:")
2909 (if description
2910 (list "Content-Description:")
2911 nil))
2912 nil)
2913 ;; remove header/text separator
2914 (goto-char (1- (vm-mm-layout-body-start layout)))
2915 (if (looking-at "\n")
2916 (delete-char 1)))
2917 (insert "Content-Type: " type)
2918 (if params
2919 (if vm-mime-avoid-folding-content-type
2920 (insert "; " (mapconcat 'identity params "; ") "\n")
2921 (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n"))
2922 (insert "\n"))
2923 (and description
2924 (insert "Content-Description: " description "\n"))
2925 (if disposition
2926 (progn
2927 (insert "Content-Disposition: " (car disposition))
2928 (if (cdr disposition)
2929 (insert ";\n\t" (mapconcat 'identity
2930 (cdr disposition)
2931 ";\n\t")))
2932 (insert "\n")))
2933 (insert "Content-Transfer-Encoding: " encoding "\n\n"))
2934 (goto-char (point-max))
2935 (widen)
2936 (save-excursion
2937 (goto-char (overlay-start o))
2938 (vm-assert (looking-at "\\[ATTACHMENT")))
2939 (delete-region (overlay-start o)
2940 (overlay-end o))
2941 (delete-overlay o)
2942 (if (looking-at "\n")
2943 (delete-char 1))
2944 (setq o-list (cdr o-list)))
2945 ;; handle the remaining chunk of text after the last
2946 ;; extent, if any.
2947 (if (or just-one (= (point) (point-max)))
2948 nil
2949 (setq charset (vm-determine-proper-charset (point)
2950 (point-max)))
2951 (if (vm-xemacs-mule-p)
2952 (encode-coding-region (point-min) (point-max)
2953 file-coding-system))
2954 (setq encoding (vm-determine-proper-content-transfer-encoding
2955 (point)
2956 (point-max))
2957 encoding (vm-mime-transfer-encode-region encoding
2958 (point)
2959 (point-max)
2960 t))
2961 (setq 8bit (or 8bit (equal encoding "8bit")))
2962 (setq boundary-positions (cons (point-marker) boundary-positions))
2963 (insert "Content-Type: text/plain; charset=" charset "\n")
2964 (insert "Content-Transfer-Encoding: " encoding "\n\n")
2965 (goto-char (point-max)))
2966 (setq boundary (vm-mime-make-multipart-boundary))
2967 (mail-text)
2968 (while (re-search-forward (concat "^--"
2969 (regexp-quote boundary)
2970 "\\(--\\)?$")
2971 nil t)
2972 (setq boundary (vm-mime-make-multipart-boundary))
2973 (mail-text))
2974 (goto-char (point-max))
2975 (or just-one (insert "\n--" boundary "--\n"))
2976 (while boundary-positions
2977 (goto-char (car boundary-positions))
2978 (insert "\n--" boundary "\n")
2979 (setq boundary-positions (cdr boundary-positions)))
2980 (if (and just-one already-mimed)
2981 (progn
2982 (goto-char (vm-mm-layout-header-start layout))
2983 ;; trim headers
2984 (vm-reorder-message-headers
2985 nil '("Content-Description:" "Content-ID:") nil)
2986 ;; remove header/text separator
2987 (goto-char (1- (vm-mm-layout-body-start layout)))
2988 (if (looking-at "\n")
2989 (delete-char 1))
2990 ;; copy remainder to enclosing entity's header section
2991 (insert-buffer-substring (current-buffer)
2992 (vm-mm-layout-header-start layout)
2993 (vm-mm-layout-body-start layout))
2994 (delete-region (vm-mm-layout-header-start layout)
2995 (vm-mm-layout-body-start layout))))
2996 (goto-char (point-min))
2997 (vm-remove-mail-mode-header-separator)
2998 (vm-reorder-message-headers
2999 nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)")
3000 (vm-add-mail-mode-header-separator)
3001 (insert "MIME-Version: 1.0\n")
3002 (if (not just-one)
3003 (insert (if vm-mime-avoid-folding-content-type
3004 "Content-Type: multipart/mixed; boundary=\""
3005 "Content-Type: multipart/mixed;\n\tboundary=\"")
3006 boundary "\"\n")
3007 (insert "Content-Type: " type)
3008 (if params
3009 (if vm-mime-avoid-folding-content-type
3010 (insert "; " (mapconcat 'identity params "; ") "\n")
3011 (insert ";\n\t" (mapconcat 'identity params ";\n\t"))))
3012 (insert "\n"))
3013 (if just-one
3014 (and description
3015 (insert "Content-Description: " description "\n")))
3016 (if (and just-one disposition)
3017 (progn
3018 (insert "Content-Disposition: " (car disposition))
3019 (if (cdr disposition)
3020 (insert ";\n\t" (mapconcat 'identity
3021 (cdr disposition)
3022 ";\n\t")))
3023 (insert "\n")))
3024 (if just-one
3025 (insert "Content-Transfer-Encoding: " encoding "\n")
3026 (if 8bit
3027 (insert "Content-Transfer-Encoding: 8bit\n")
3028 (insert "Content-Transfer-Encoding: 7bit\n")))))))
3029
2805 (defun vm-mime-fragment-composition (size) 3030 (defun vm-mime-fragment-composition (size)
2806 (save-restriction 3031 (save-restriction
2807 (widen) 3032 (widen)
2808 (message "Fragmenting message...") 3033 (message "Fragmenting message...")
2809 (let ((buffers nil) 3034 (let ((buffers nil)
2814 (vm-remove-mail-mode-header-separator) 3039 (vm-remove-mail-mode-header-separator)
2815 ;; message/partial must have "7bit" content transfer 3040 ;; message/partial must have "7bit" content transfer
2816 ;; encoding, so verify that everything has been encoded for 3041 ;; encoding, so verify that everything has been encoded for
2817 ;; 7bit transmission. 3042 ;; 7bit transmission.
2818 (let ((vm-mime-8bit-text-transfer-encoding 3043 (let ((vm-mime-8bit-text-transfer-encoding
2819 (if (eq vm-mime-8bit-text-transfer-encoding 'send) 3044 (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
2820 'quoted-printable 3045 'quoted-printable
2821 vm-mime-8bit-text-transfer-encoding))) 3046 vm-mime-8bit-text-transfer-encoding)))
2822 (vm-mime-map-atomic-layouts 3047 (vm-mime-map-atomic-layouts
2823 'vm-mime-transfer-encode-layout 3048 'vm-mime-transfer-encode-layout
2824 (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") 3049 (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
2863 (insert mail-header-separator "\n") 3088 (insert mail-header-separator "\n")
2864 (insert-buffer-substring master-buffer start end) 3089 (insert-buffer-substring master-buffer start end)
2865 (vm-increment n) 3090 (vm-increment n)
2866 (set-buffer master-buffer) 3091 (set-buffer master-buffer)
2867 (setq start (point))) 3092 (setq start (point)))
3093 (vm-add-mail-mode-header-separator)
2868 (message "Fragmenting message... done") 3094 (message "Fragmenting message... done")
2869 (nreverse buffers)))) 3095 (nreverse buffers))))
2870 3096
2871 (defun vm-mime-preview-composition () 3097 (defun vm-mime-preview-composition ()
2872 "Show how the current composition buffer might be displayed 3098 "Show how the current composition buffer might be displayed
2885 (setq temp-buffer (generate-new-buffer "composition preview")) 3111 (setq temp-buffer (generate-new-buffer "composition preview"))
2886 (set-buffer temp-buffer) 3112 (set-buffer temp-buffer)
2887 ;; so vm-mime-encode-composition won't complain 3113 ;; so vm-mime-encode-composition won't complain
2888 (setq major-mode 'mail-mode) 3114 (setq major-mode 'mail-mode)
2889 (vm-insert-region-from-buffer mail-buffer) 3115 (vm-insert-region-from-buffer mail-buffer)
3116 (vm-remove-mail-mode-header-separator)
2890 (goto-char (point-min)) 3117 (goto-char (point-min))
2891 (or (vm-mail-mode-get-header-contents "From") 3118 (or (vm-mail-mode-get-header-contents "From")
2892 (insert "From: " (user-login-name) "\n")) 3119 (insert "From: " (user-login-name) "\n"))
2893 (or (vm-mail-mode-get-header-contents "Message-ID") 3120 (or (vm-mail-mode-get-header-contents "Message-ID")
2894 (insert "Message-ID: <fake@fake.fake>\n")) 3121 (insert "Message-ID: <fake@fake.fake>\n"))