Mercurial > hg > xemacs-beta
diff lisp/vm/vm-mime.el @ 54:05472e90ae02 r19-16-pre2
Import from CVS: tag r19-16-pre2
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:57:55 +0200 |
| parents | 8b8b7f3559a2 |
| children |
line wrap: on
line diff
--- a/lisp/vm/vm-mime.el Mon Aug 13 08:57:25 2007 +0200 +++ b/lisp/vm/vm-mime.el Mon Aug 13 08:57:55 2007 +0200 @@ -38,9 +38,12 @@ (defun vm-mm-layout-body-end (e) (aref e 9)) (defun vm-mm-layout-parts (e) (aref e 10)) (defun vm-mm-layout-cache (e) (aref e 11)) +;; if display of MIME part fails, error string will be here. +(defun vm-mm-layout-display-error (e) (aref e 12)) (defun vm-set-mm-layout-type (e type) (aset e 0 type)) (defun vm-set-mm-layout-cache (e c) (aset e 11 c)) +(defun vm-set-mm-layout-display-error (e c) (aset e 12 c)) (defun vm-mm-layout (m) (or (vm-mime-layout-of m) @@ -104,7 +107,7 @@ (defun vm-mime-charset-decode-region (charset start end) (or (markerp end) (setq end (vm-marker end))) - (cond ((vm-xemacs-mule-p) + (cond (vm-xemacs-mule-p (if (eq (device-type) 'x) (let ((buffer-read-only nil) (cell (cdr (vm-string-assoc @@ -344,7 +347,7 @@ ((looking-at "\n") ; soft line break (forward-char)) ((looking-at "\r") - ;; assume the user's goatfucking + ;; assume the user's goatloving ;; delivery software didn't convert ;; from Internet's CRLF newline ;; convention to the local LF @@ -391,7 +394,9 @@ (vm-increment cols)) ((or (< char 33) (> char 126) (= char 61) (and quote-from (= cols 0) (let ((case-fold-search nil)) - (looking-at "From ")))) + (looking-at "From "))) + (and (= cols 0) (= char ?.) + (looking-at "\\.\\(\n\\|\\'\\)"))) (vm-insert-char ?= 1 nil work-buffer) (vm-insert-char (car (rassq (lsh char -4) hex-digit-alist)) 1 nil work-buffer) @@ -526,85 +531,7 @@ (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words) string )) -(defun vm-mime-parse-content-header (string &optional sepchar keep-quotes) - (if (null string) - () - (let ((work-buffer nil)) - (save-excursion - (unwind-protect - (let ((list nil) - (nonspecials "^\"\\( \t\n\r\f") - start s char sp+sepchar) - (if sepchar - (setq nonspecials (concat nonspecials (list sepchar)) - sp+sepchar (concat "\t\f\n\r " (list sepchar)))) - (setq work-buffer (generate-new-buffer "*vm-work*")) - (buffer-disable-undo work-buffer) - (set-buffer work-buffer) - (insert string) - (goto-char (point-min)) - (skip-chars-forward "\t\f\n\r ") - (setq start (point)) - (while (not (eobp)) - (skip-chars-forward nonspecials) - (setq char (following-char)) - (cond ((looking-at "[ \t\n\r\f]") - (delete-char 1)) - ((= char ?\\) - (forward-char 1) - (if (not (eobp)) - (forward-char 1))) - ((and sepchar (= char sepchar)) - (setq s (buffer-substring start (point))) - (if (or (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (skip-chars-forward sp+sepchar) - (setq start (point))) - ((looking-at " \t\n\r\f") - (skip-chars-forward " \t\n\r\f")) - ((= char ?\") - (let ((done nil)) - (if keep-quotes - (forward-char 1) - (delete-char 1)) - (while (not done) - (if (null (re-search-forward "[\\\"]" nil t)) - (setq done t) - (setq char (char-after (1- (point)))) - (cond ((char-equal char ?\\) - (delete-char -1) - (if (eobp) - (setq done t) - (forward-char 1))) - (t (if (not keep-quotes) - (delete-char -1)) - (setq done t))))))) - ((= char ?\() - (let ((done nil) - (pos (point)) - (parens 1)) - (forward-char 1) - (while (not done) - (if (null (re-search-forward "[\\()]" nil t)) - (setq done t) - (setq char (char-after (1- (point)))) - (cond ((char-equal char ?\\) - (if (eobp) - (setq done t) - (forward-char 1))) - ((char-equal char ?\() - (setq parens (1+ parens))) - (t - (setq parens (1- parens) - done (zerop parens)))))) - (delete-region pos (point)))))) - (setq s (buffer-substring start (point))) - (if (and (null (string-match "^[\t\f\n\r ]+$" s)) - (not (string= s ""))) - (setq list (cons s list))) - (nreverse list)) - (and work-buffer (kill-buffer work-buffer))))))) +(fset 'vm-mime-parse-content-header 'vm-parse-structured-header) (defun vm-mime-get-header-contents (header-name-regexp) (let ((contents nil) @@ -641,7 +568,9 @@ encoding (or (vm-get-header-contents m "Content-Transfer-Encoding:") "7bit") - encoding (car (vm-mime-parse-content-header encoding)) + encoding (or (car + (vm-mime-parse-content-header encoding)) + "7bit") id (vm-get-header-contents m "Content-ID:") id (car (vm-mime-parse-content-header id)) description (vm-get-header-contents @@ -670,7 +599,8 @@ encoding (or (vm-mime-get-header-contents "Content-Transfer-Encoding:") default-encoding) - encoding (car (vm-mime-parse-content-header encoding)) + encoding (or (car (vm-mime-parse-content-header encoding)) + default-encoding) id (vm-mime-get-header-contents "Content-ID:") id (car (vm-mime-parse-content-header id)) description (vm-mime-get-header-contents @@ -745,7 +675,7 @@ (narrow-to-region (point) (point-max)) (vm-mime-parse-entity-safe nil c-t c-t-e))) - nil ))) + nil nil ))) (t (goto-char (point-min)) (or (re-search-forward "^\n\\|\n\\'" nil t) @@ -756,7 +686,7 @@ (vm-marker (point-min)) (vm-marker (point)) (vm-marker (point-max)) - nil nil )))) + nil nil nil )))) (setq p (cdr type) boundary nil) (while p @@ -803,7 +733,7 @@ (vm-marker (point)) (vm-marker (point-max)) (nreverse multipart-list) - nil ))))))) + nil nil ))))))) (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) @@ -834,7 +764,8 @@ '("attachment") '("attachment") header text - text-end))))) + text-end + nil nil nil))))) (defun vm-mime-get-xxx-parameter (layout name param-list) (let ((match-end (1+ (length name))) @@ -900,9 +831,9 @@ (defvar scroll-in-place) (make-local-variable 'scroll-in-place) (setq scroll-in-place nil) - (and (vm-xemacs-mule-p) - (set-file-coding-system 'binary t)) - (cond ((vm-fsfemacs-19-p) + (and vm-xemacs-mule-p + (set-buffer-file-coding-system 'binary t)) + (cond (vm-fsfemacs-19-p ;; need to do this outside the let because ;; loading disp-table initializes ;; standard-display-table. @@ -911,7 +842,8 @@ (copy-sequence standard-display-table))) (standard-display-european t) (setq buffer-display-table standard-display-table)))) - (if (and vm-frame-per-folder (vm-multiple-frames-possible-p)) + (if (and vm-mutable-frames vm-frame-per-folder + (vm-multiple-frames-possible-p)) (vm-set-hooks-for-frame-deletion)) (use-local-map vm-mode-map) (and (vm-toolbar-support-possible-p) vm-use-toolbar @@ -935,6 +867,8 @@ (set-buffer b) (widen) (let ((buffer-read-only nil) + ;; disable read-only text properties + (inhibit-read-only t) (modified (buffer-modified-p))) (unwind-protect (progn @@ -966,7 +900,7 @@ (fset 'vm-presentation-mode 'vm-mode) (put 'vm-presentation-mode 'mode-class 'special) -(defvar file-coding-system) +(defvar buffer-file-coding-system) (defun vm-determine-proper-charset (beg end) (save-excursion @@ -974,14 +908,15 @@ (narrow-to-region beg end) (catch 'done (goto-char (point-min)) - (if (vm-xemacs-mule-p) + (if vm-xemacs-mule-p (let ((charsets (delq 'ascii (charsets-in-region beg end)))) (cond ((null charsets) "us-ascii") ((cdr charsets) (or (car (cdr - (assoc (coding-system-name file-coding-system) - vm-mime-mule-coding-to-charset-alist))) + (assq (coding-system-name + buffer-file-coding-system) + vm-mime-mule-coding-to-charset-alist))) "iso-2022-jp")) (t (or (car (cdr @@ -1037,23 +972,23 @@ (defun vm-mime-can-display-internal (layout) (let ((type (car (vm-mm-layout-type layout)))) (cond ((vm-mime-types-match "image/jpeg" type) - (and (vm-xemacs-p) + (and vm-xemacs-p (featurep 'jpeg) (eq (device-type) 'x))) ((vm-mime-types-match "image/gif" type) - (and (vm-xemacs-p) + (and vm-xemacs-p (featurep 'gif) (eq (device-type) 'x))) ((vm-mime-types-match "image/png" type) - (and (vm-xemacs-p) + (and vm-xemacs-p (featurep 'png) (eq (device-type) 'x))) ((vm-mime-types-match "image/tiff" type) - (and (vm-xemacs-p) + (and vm-xemacs-p (featurep 'tiff) (eq (device-type) 'x))) ((vm-mime-types-match "audio/basic" type) - (and (vm-xemacs-p) + (and vm-xemacs-p (or (featurep 'native-sound) (featurep 'nas-sound)) (or (device-sound-enabled-p) @@ -1068,13 +1003,11 @@ (let ((charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (vm-mime-charset-internally-displayable-p charset))) -;; commented out until w3-region behavior gets worked out -;; -;; ((vm-mime-types-match "text/html" type) -;; (condition-case () -;; (progn (require 'w3) -;; (fboundp 'w3-region)) -;; (error nil))) + ((vm-mime-types-match "text/html" type) + (condition-case () + (progn (require 'w3) + (fboundp 'w3-region)) + (error nil))) (t nil)))) (defun vm-mime-can-convert (type) @@ -1126,7 +1059,8 @@ (vm-marker (point)) (vm-marker (point-max)) nil - nil )))) + nil + nil)))) (defun vm-mime-should-display-button (layout dont-honor-content-disposition) (if (and vm-honor-mime-content-disposition @@ -1327,7 +1261,9 @@ ;; text/plain. (vm-mime-display-internal-text/plain layout))) (t (and extent (vm-mime-rewrite-failed-button - extent (vm-mm-layout-cache layout))) + extent + (or (vm-mm-layout-display-error layout) + "no external viewer defined for type"))) (vm-mime-display-internal-application/octet-stream (or extent layout)))) (and extent (vm-mime-delete-button-maybe extent))) @@ -1337,28 +1273,29 @@ (defun vm-mime-display-button-text (layout) (vm-mime-display-button-xxxx layout t)) -;; commented out until w3-region behavior is worked out -;; -;;(defun vm-mime-display-internal-text/html (layout) -;; (let ((buffer-read-only nil) -;; (work-buffer nil)) -;; (message "Inlining text/html, be patient...") -;; ;; w3-region is not as tame as we would like. -;; ;; make sure the yoke is firmly attached. -;; (unwind-protect -;; (progn -;; (save-excursion -;; (set-buffer (setq work-buffer -;; (generate-new-buffer " *workbuf*"))) -;; (vm-mime-insert-mime-body layout) -;; (vm-mime-transfer-decode-region layout (point-min) (point-max)) -;; (save-excursion -;; (save-window-excursion -;; (w3-region (point-min) (point-max))))) -;; (insert-buffer-substring work-buffer)) -;; (and work-buffer (kill-buffer work-buffer))) -;; (message "Inlining text/html... done") -;; t )) +(defun vm-mime-display-internal-text/html (layout) + (if (fboundp 'w3-region) + (let ((buffer-read-only nil) + (work-buffer nil)) + (message "Inlining text/html, be patient...") + ;; w3-region is not as tame as we would like. + ;; make sure the yoke is firmly attached. + (unwind-protect + (progn + (save-excursion + (set-buffer (setq work-buffer + (generate-new-buffer " *workbuf*"))) + (vm-mime-insert-mime-body layout) + (vm-mime-transfer-decode-region layout (point-min) (point-max)) + (save-excursion + (save-window-excursion + (w3-region (point-min) (point-max))))) + (insert-buffer-substring work-buffer)) + (and work-buffer (kill-buffer work-buffer))) + (message "Inlining text/html... done") + t ) + (vm-set-mm-layout-display-error layout "Need W3 to inline HTML") + nil )) (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) (let ((start (point)) end old-size @@ -1366,7 +1303,7 @@ (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (if (not (vm-mime-charset-internally-displayable-p charset)) (progn - (vm-set-mm-layout-cache + (vm-set-mm-layout-display-error layout (concat "Undisplayable charset: " charset)) nil) (vm-mime-insert-mime-body layout) @@ -1403,11 +1340,13 @@ (defun vm-mime-display-external-generic (layout) (let ((program-list (vm-mime-find-external-viewer (car (vm-mm-layout-type layout)))) - (process (nth 0 (vm-mm-layout-cache layout))) - (tempfile (nth 1 (vm-mm-layout-cache layout))) (buffer-read-only nil) (start (point)) - end) + process tempfile cache end) + (setq cache (cdr (assq 'vm-mime-display-external-generic + (vm-mm-layout-cache layout))) + process (nth 0 cache) + tempfile (nth 1 cache)) (if (and (processp process) (eq (process-status process) 'run)) t (cond ((or (null tempfile) (null (file-exists-p tempfile))) @@ -1416,15 +1355,20 @@ (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile-name)) (let ((buffer-file-type buffer-file-type) - file-coding-system) + buffer-file-coding-system) ;; Tell DOS/Windows NT whether the file is binary (setq buffer-file-type (not (vm-mime-text-type-p layout))) ;; Tell XEmacs/MULE not to mess with the bits unless ;; this is a text type. - (if (vm-xemacs-mule-p) + (if vm-xemacs-mule-p (if (vm-mime-text-type-p layout) - (set-file-coding-system 'no-conversion nil) - (set-file-coding-system 'binary t))) + (set-buffer-file-coding-system 'no-conversion nil) + (set-buffer-file-coding-system 'binary t))) + ;; Write an empty tempfile out to disk and set its + ;; permissions to 0600, then write the actual buffer + ;; contents to tempfile. + (write-region start start tempfile nil 0) + (set-file-modes tempfile 384) (write-region start end tempfile nil 0)) (delete-region start end) (save-excursion @@ -1446,7 +1390,11 @@ (setq vm-message-garbage-alist (cons (cons process 'delete-process) vm-message-garbage-alist))) - (vm-set-mm-layout-cache layout (list process tempfile)))) + (vm-set-mm-layout-cache + layout + (nconc (vm-mm-layout-cache layout) + (list (cons 'vm-mime-display-external-generic + (list process tempfile))))))) t ) (defun vm-mime-display-internal-application/octet-stream (layout) @@ -1456,7 +1404,7 @@ (vm-mime-insert-button (format "%-35.35s [%s to save to a file]" (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-p) + (if (vm-mouse-support-possible-here-p) "Click mouse-2" "Press RETURN")) (function @@ -1475,9 +1423,12 @@ (vm-mime-get-parameter layout "name")))) (vm-mime-send-body-to-file layout default-filename))) t ) -(fset 'vm-mime-display-button-application +(fset 'vm-mime-display-button-application/octet-stream 'vm-mime-display-internal-application/octet-stream) +(defun vm-mime-display-button-application (layout) + (vm-mime-display-button-xxxx layout nil)) + (defun vm-mime-display-button-image (layout) (vm-mime-display-button-xxxx layout t)) @@ -1540,7 +1491,7 @@ (vm-mime-insert-button (format "%-35.35s [%s to display in parallel]" (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-p) + (if (vm-mouse-support-possible-here-p) "Click mouse-2" "Press RETURN")) (function @@ -1559,7 +1510,7 @@ (vm-mime-insert-button (format "%-35.35s [%s to display]" (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-p) + (if (vm-mouse-support-possible-here-p) "Click mouse-2" "Press RETURN")) (function @@ -1586,20 +1537,36 @@ (fset 'vm-mime-display-button-multipart/digest 'vm-mime-display-internal-multipart/digest) +(defun vm-mime-display-button-message/rfc822 (layout) + (let ((buffer-read-only nil)) + (vm-mime-insert-button + (format "%-35.35s [%s to display]" + (vm-mime-layout-description layout) + (if (vm-mouse-support-possible-here-p) + "Click mouse-2" + "Press RETURN")) + (function + (lambda (layout) + (save-excursion + (vm-mime-display-internal-message/rfc822 layout)))) + layout nil))) +(fset 'vm-mime-display-button-message/news + 'vm-mime-display-button-message/rfc822) + (defun vm-mime-display-internal-message/rfc822 (layout) (if (vectorp layout) - (let ((buffer-read-only nil)) - (vm-mime-insert-button - (format "%-35.35s [%s to display]" - (vm-mime-layout-description layout) - (if (vm-mouse-support-possible-p) - "Click mouse-2" - "Press RETURN")) - (function - (lambda (layout) - (save-excursion - (vm-mime-display-internal-message/rfc822 layout)))) - layout nil)) + (let ((start (point)) + (buffer-read-only nil)) + (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout))) + (insert ?\n) + (save-excursion + (goto-char start) + (vm-reorder-message-headers nil vm-visible-headers + vm-invisible-header-regexp)) + (save-restriction + (narrow-to-region start (point)) + (vm-decode-mime-encoded-words)) + (vm-mime-display-internal-multipart/mixed layout)) (goto-char (vm-extent-start-position layout)) (setq layout (vm-extent-property layout 'vm-mime-layout)) (set-buffer (generate-new-buffer @@ -1618,8 +1585,6 @@ (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup))) t ) -(fset 'vm-mime-display-button-message/rfc822 - 'vm-mime-display-internal-message/rfc822) (fset 'vm-mime-display-internal-message/news 'vm-mime-display-internal-message/rfc822) @@ -1633,7 +1598,7 @@ (concat (vm-mime-layout-description layout) (and number (concat ", part " number)) (and number total (concat " of " total))) - (if (vm-mouse-support-possible-p) + (if (vm-mouse-support-possible-here-p) "Click mouse-2" "Press RETURN")) (function @@ -1758,28 +1723,45 @@ 'vm-mime-display-internal-message/partial) (defun vm-mime-display-internal-image-xxxx (layout feature name) - (if (and (vm-xemacs-p) + (if (and vm-xemacs-p (featurep feature) (eq (device-type) 'x)) (let ((start (point)) end tempfile g e (buffer-read-only nil)) - (if (vm-mm-layout-cache layout) - (setq g (vm-mm-layout-cache layout)) + (if (setq g (cdr (assq 'vm-mime-display-internal-image-xxxx + (vm-mm-layout-cache layout)))) + nil (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile-name)) - ;; coding system for presentation buffer is binary + ;; Write an empty tempfile out to disk and set its + ;; permissions to 0600, then write the actual buffer + ;; contents to tempfile. + (write-region start start tempfile nil 0) + (set-file-modes tempfile 384) + ;; coding system for presentation buffer is binary so + ;; we don't need to set it here. (write-region start end tempfile nil 0) (message "Creating %s glyph..." name) (setq g (make-glyph - (list (vector feature ':file tempfile) - (vector 'string - ':data - (format "[Unknown %s image encoding]\n" - name))))) + (list + (cons (list 'win) + (vector feature ':file tempfile)) + (cons (list 'win) + (vector 'string + ':data + (format "[Unknown/Bad %s image encoding]\n" + name))) + (cons nil + (vector 'string + ':data + (format "[%s image]\n" name)))))) (message "") - (vm-set-mm-layout-cache layout g) + (vm-set-mm-layout-cache + layout + (nconc (vm-mm-layout-cache layout) + (list (cons 'vm-mime-display-internal-image-xxxx g)))) (save-excursion (vm-select-folder-buffer) (setq vm-folder-garbage-alist @@ -1806,7 +1788,7 @@ (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF")) (defun vm-mime-display-internal-audio/basic (layout) - (if (and (vm-xemacs-p) + (if (and vm-xemacs-p (or (featurep 'native-sound) (featurep 'nas-sound)) (or (device-sound-enabled-p) @@ -1815,15 +1797,26 @@ (eq (device-type) 'x)))) (let ((start (point)) end tempfile (buffer-read-only nil)) - (if (vm-mm-layout-cache layout) - (setq tempfile (vm-mm-layout-cache layout)) + (if (setq tempfile (cdr (assq 'vm-mime-display-internal-audio/basic + (vm-mm-layout-cache layout)))) + nil (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile-name)) - ;; coding system for presentation buffer is binary + ;; Write an empty tempfile out to disk and set its + ;; permissions to 0600, then write the actual buffer + ;; contents to tempfile. + (write-region start start tempfile nil 0) + (set-file-modes tempfile 384) + ;; coding system for presentation buffer is binary, so + ;; we don't need to set it here. (write-region start end tempfile nil 0) - (vm-set-mm-layout-cache layout tempfile) + (vm-set-mm-layout-cache + layout + (nconc (vm-mm-layout-cache layout) + (list (cons 'vm-mime-display-internal-audio/basic + tempfile)))) (save-excursion (vm-select-folder-buffer) (setq vm-folder-garbage-alist @@ -1839,9 +1832,11 @@ (defun vm-mime-display-button-xxxx (layout disposable) (let ((description (vm-mime-layout-description layout))) (vm-mime-insert-button - (format "%-35.35s [%s to display]" + (format "%-35.35s [%s to attempt display]" description - (if (vm-mouse-support-possible-p) "Click mouse-2" "Press RETURN")) + (if (vm-mouse-support-possible-here-p) + "Click mouse-2" + "Press RETURN")) (function (lambda (layout) (save-excursion @@ -1856,7 +1851,7 @@ ;; drag window point along, to a place arbitrarily far from ;; where it was when the user triggered the button. (save-excursion - (cond ((vm-fsfemacs-19-p) + (cond (vm-fsfemacs-19-p (let (o-list o (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) @@ -1866,7 +1861,7 @@ 'vm-mime-function)) (car o-list)))) (setq o-list (cdr o-list))))) - ((vm-xemacs-p) + (vm-xemacs-p (let ((e (extent-at (point) nil 'vm-mime-layout))) (funcall (or function (extent-property e 'vm-mime-function)) e)))))) @@ -1874,42 +1869,40 @@ ;; for the karking compiler (defvar vm-menu-mime-dispose-menu) -(defun vm-mime-set-extent-glyph-for-layout (e layout) - (if (and (vm-xemacs-p) (fboundp 'make-glyph) - (eq (device-type) 'x) (> (device-bitplanes) 15)) - (let ((type (car (vm-mm-layout-type layout))) - (dir vm-image-directory) - glyph) - (setq glyph - (cond ((vm-mime-types-match "text" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "document.xpm" dir)))) - ((vm-mime-types-match "image" type) - (make-glyph (vector - 'gif ':file - (expand-file-name "mona_stamp.gif" dir)))) - ((vm-mime-types-match "audio" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "audio_stamp.xpm" dir)))) - ((vm-mime-types-match "video" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "film.xpm" dir)))) - ((vm-mime-types-match "message" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "message.xpm" dir)))) - ((vm-mime-types-match "application" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "gear.xpm" dir)))) - ((vm-mime-types-match "multipart" type) - (make-glyph (vector - 'xpm ':file - (expand-file-name "stuffed_box.xpm" dir)))) - (t nil))) +(defun vm-mime-set-extent-glyph-for-type (e type) + (if (and vm-xemacs-p + (featurep 'xpm) + (eq (device-type) 'x) + (> (device-bitplanes) 7)) + (let ((dir vm-image-directory) + (colorful (> (device-bitplanes) 15)) + (tuples + '(("text" "document-simple.xpm" "document-colorful.xpm") + ("image" "mona_stamp-simple.xpm" "mona_stamp-colorful.xpm") + ("audio" "audio_stamp-simple.xpm" "audio_stamp-colorful.xpm") + ("video" "film-simple.xpm" "film-colorful.xpm") + ("message" "message-simple.xpm" "message-colorful.xpm") + ("application" "gear-simple.xpm" "gear-colorful.xpm") + ("multipart" "stuffed_box-simple.xpm" + "stuffed_box-colorful.xpm"))) + glyph file sym p) + (setq file (catch 'done + (while tuples + (if (vm-mime-types-match (car (car tuples)) type) + (throw 'done (car tuples)) + (setq tuples (cdr tuples)))) + nil) + file (and file (if colorful (nth 2 file) (nth 1 file))) + sym (and file (intern file vm-image-obarray)) + glyph (and sym (boundp sym) (symbol-value sym)) + glyph (or glyph + (and file + (make-glyph + (list + (vector 'xpm ':file + (expand-file-name file dir)) + [nothing]))))) + (and sym (not (boundp sym)) (set sym glyph)) (and glyph (set-extent-begin-glyph e glyph))))) (defun vm-mime-insert-button (caption action layout disposable) @@ -1926,16 +1919,18 @@ (if (not (bolp)) (insert "\n")) (insert caption "\n") - ;; we MUST have the five arg make-overlay. overlays must - ;; advance when text is inserted at their start position or - ;; inline text and graphics will seep into the button - ;; overlay and then be removed when the button is removed. - (if (fboundp 'make-overlay) + ;; we must use the same interface that the vm-extent functions + ;; use. if they use overlays, then we call make-overlay. + (if (eq (symbol-function 'vm-make-extent) 'make-overlay) + ;; we MUST have the five arg make-overlay. overlays must + ;; advance when text is inserted at their start position or + ;; inline text and graphics will seep into the button + ;; overlay and then be removed when the button is removed. (setq e (make-overlay start (point) nil t nil)) (setq e (make-extent start (point))) (set-extent-property e 'start-open t) (set-extent-property e 'end-open t)) - (vm-mime-set-extent-glyph-for-layout e layout) + (vm-mime-set-extent-glyph-for-type e (car (vm-mm-layout-type layout))) ;; for emacs (vm-set-extent-property e 'mouse-face 'highlight) (vm-set-extent-property e 'local-map keymap) @@ -1953,7 +1948,7 @@ (let* ((buffer-read-only nil) (start (point))) (goto-char (vm-extent-start-position button)) - (insert (format "DISPLAY FAILED -- %s" error-string)) + (insert (format "DISPLAY FAILED -- %s\n" error-string)) (vm-set-extent-endpoints button start (vm-extent-end-position button)) (delete-region (point) (vm-extent-end-position button)))) @@ -2000,10 +1995,10 @@ (setq buffer-file-type (not (vm-mime-text-type-p layout))) ;; Tell XEmacs/MULE not to mess with the bits unless ;; this is a text type. - (if (vm-xemacs-mule-p) + (if vm-xemacs-mule-p (if (vm-mime-text-type-p layout) - (set-file-coding-system 'no-conversion nil) - (set-file-coding-system 'binary t))) + (set-buffer-file-coding-system 'no-conversion nil) + (set-buffer-file-coding-system 'binary t))) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (or (not (file-exists-p file)) @@ -2144,6 +2139,24 @@ (setq done t) (setq p (cdr p)))) result ))) + +;; breadth first traversal +(defun vm-mime-find-digests-in-layout (layout) + (let ((layout-list (list layout)) + layout-type + (result nil)) + (while layout-list + (setq layout-type (car (vm-mm-layout-type (car layout-list)))) + (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)" + layout-type) + (setq result (nconc result (list (car layout-list))))) + ((vm-mime-composite-type-p layout-type) + (setq layout-list (nconc layout-list + (copy-sequence + (vm-mm-layout-parts + (car layout-list))))))) + (setq layout-list (cdr layout-list))) + result )) (defun vm-mime-plain-message-p (m) (save-match-data @@ -2164,7 +2177,7 @@ (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) (defun vm-mime-charset-internally-displayable-p (name) - (cond ((and (vm-xemacs-mule-p) (eq (device-type) 'x)) + (cond ((and vm-xemacs-mule-p (eq (device-type) 'x)) (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)) ((vm-multiple-fonts-possible-p) (or (vm-string-member name vm-mime-default-face-charsets) @@ -2199,7 +2212,7 @@ (car mp))) (defun vm-mime-make-multipart-boundary () - (let ((boundary (make-string 40 ?a)) + (let ((boundary (make-string 10 ?a)) (i 0)) (random t) (while (< i (length boundary)) @@ -2330,7 +2343,7 @@ (file-name-nondirectory object) "\""))))) (setq disposition (list "unspecified"))) - (cond ((vm-fsfemacs-19-p) + (cond (vm-fsfemacs-19-p (put-text-property start end 'front-sticky nil) (put-text-property start end 'rear-nonsticky t) ;; can't be intangible because menu clicking at a position needs @@ -2345,38 +2358,39 @@ (put-text-property start end 'vm-mime-disposition disposition) (put-text-property start end 'vm-mime-encoded mimed) (put-text-property start end 'vm-mime-object object)) - ((fboundp 'make-extent) + (vm-xemacs-p (setq e (make-extent start end)) + (vm-mime-set-extent-glyph-for-type e (or type "text/plain")) (set-extent-property e 'start-open t) (set-extent-property e 'face vm-mime-button-face) - (vm-set-extent-property e 'duplicable t) + (set-extent-property e 'duplicable t) (let ((keymap (make-sparse-keymap))) (if vm-popup-menu-on-mouse-3 (define-key keymap 'button3 'vm-menu-popup-content-disposition-menu)) - (vm-set-extent-property e 'keymap keymap) + (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help)) - (vm-set-extent-property e 'vm-mime-type type) - (vm-set-extent-property e 'vm-mime-object object) - (vm-set-extent-property e 'vm-mime-parameters params) - (vm-set-extent-property e 'vm-mime-description description) - (vm-set-extent-property e 'vm-mime-disposition disposition) - (vm-set-extent-property e 'vm-mime-encoded mimed))))) + (set-extent-property e 'vm-mime-type type) + (set-extent-property e 'vm-mime-object object) + (set-extent-property e 'vm-mime-parameters params) + (set-extent-property e 'vm-mime-description description) + (set-extent-property e 'vm-mime-disposition disposition) + (set-extent-property e 'vm-mime-encoded mimed))))) (defun vm-mime-attachment-disposition-at-point () - (cond ((vm-fsfemacs-19-p) + (cond (vm-fsfemacs-19-p (let ((disp (get-text-property (point) 'vm-mime-disposition))) (intern (car disp)))) - ((vm-xemacs-p) + (vm-xemacs-p (let* ((e (extent-at (point) nil 'vm-mime-disposition)) (disp (extent-property e 'vm-mime-disposition))) (intern (car disp)))))) (defun vm-mime-set-attachment-disposition-at-point (sym) - (cond ((vm-fsfemacs-19-p) + (cond (vm-fsfemacs-19-p (let ((disp (get-text-property (point) 'vm-mime-disposition))) (setcar disp (symbol-name sym)))) - ((vm-xemacs-p) + (vm-xemacs-p (let* ((e (extent-at (point) nil 'vm-mime-disposition)) (disp (extent-property e 'vm-mime-disposition))) (setcar disp (symbol-name sym)))))) @@ -2447,11 +2461,16 @@ (let ((case-fold-search nil)) (save-excursion (goto-char beg) - (re-search-forward "^From " nil t)))))) + (re-search-forward "^From " nil t))))) + (armor-dot (let ((case-fold-search nil)) + (save-excursion + (goto-char beg) + (re-search-forward "^\\.\\n" nil t))))) (cond ((string-match "^binary$" encoding) (vm-mime-base64-encode-region beg end crlf) (setq encoding "base64")) - ((and (not armor-from) (string-match "^7bit$" encoding)) t) + ((and (not armor-from) (not armor-dot) + (string-match "^7bit$" encoding)) t) ((string-match "^base64$" encoding) t) ((string-match "^quoted-printable$" encoding) t) ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) @@ -2465,21 +2484,72 @@ encoding )) (defun vm-mime-transfer-encode-layout (layout) - (if (vm-mime-text-type-p layout) - (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) - (vm-mm-layout-body-start layout) - (vm-mm-layout-body-end layout) - t) - (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) - (vm-mm-layout-body-start layout) - (vm-mm-layout-body-end layout) - nil))) + (let ((list (vm-mm-layout-parts layout)) + (type (car (vm-mm-layout-type layout))) + (encoding "7bit") + (vm-mime-8bit-text-transfer-encoding + vm-mime-8bit-text-transfer-encoding)) + (cond ((vm-mime-composite-type-p type) + ;; MIME messages of type "message" and + ;; "multipart" are required to have a non-opaque + ;; content transfer encoding. This means that + ;; if the user only wants to send out 7bit data, + ;; then any subpart that contains 8bit data must + ;; have an opaque (qp or base64) 8->7bit + ;; conversion performed on it so that the + ;; enclosing entity can use a non-opaque + ;; encoding. + ;; + ;; message/partial requires a "7bit" encoding so + ;; force 8->7 conversion in that case. + (cond ((memq vm-mime-8bit-text-transfer-encoding + '(quoted-printable base64)) + t) + ((vm-mime-types-match "message/partial" type) + (setq vm-mime-8bit-text-transfer-encoding + 'quoted-printable))) + (while list + (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit") + (setq encoding "8bit")) + (setq list (cdr list)))) + (t + (if (and (vm-mime-types-match "message/partial" type) + (not (memq vm-mime-8bit-text-transfer-encoding + '(quoted-printable base64)))) + (setq vm-mime-8bit-text-transfer-encoding + 'quoted-printable)) + (setq encoding + (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) + (vm-mm-layout-body-start layout) + (vm-mm-layout-body-end layout) + (vm-mime-text-type-p layout))))) + (save-excursion + (save-restriction + (goto-char (vm-mm-layout-header-start layout)) + (narrow-to-region (point) (vm-mm-layout-body-start layout)) + (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:") + (if (not (equal encoding "7bit")) + (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n")) + encoding )))) (defun vm-mime-encode-composition () - "MIME encode the current buffer. + "MIME encode the current mail composition buffer. Attachment tags added to the buffer with vm-mime-attach-file are expanded and the approriate content-type and boundary markup information is added." (interactive) + (cond (vm-xemacs-mule-p + (vm-mime-xemacs-encode-composition)) + (vm-xemacs-p + (vm-mime-xemacs-encode-composition)) + (vm-fsfemacs-19-p + (vm-mime-fsfemacs-encode-composition)) + (t + (error "don't know how to MIME encode composition for %s" + (emacs-version))))) + +(defvar enriched-mode) + +(defun vm-mime-xemacs-encode-composition () (save-restriction (widen) (if (not (eq major-mode 'mail-mode)) @@ -2489,21 +2559,20 @@ (let ((8bit nil) (just-one nil) (boundary-positions nil) + (enriched (and (boundp 'enriched-mode) enriched-mode)) already-mimed layout e e-list boundary type encoding charset params description disposition object opoint-min) (mail-text) - (setq e-list (if (fboundp 'extent-list) - (extent-list nil (point) (point-max)) - (vm-mime-fake-attachment-overlays (point) (point-max))) + (setq e-list (extent-list nil (point) (point-max)) e-list (vm-delete (function (lambda (e) - (vm-extent-property e 'vm-mime-object))) + (extent-property e 'vm-mime-object))) e-list t) e-list (sort e-list (function (lambda (e1 e2) - (< (vm-extent-end-position e1) - (vm-extent-end-position e2)))))) + (< (extent-end-position e1) + (extent-end-position e2)))))) ;; If there's just one attachment and no other readable ;; text in the buffer then make the message type just be ;; the attachment type rather than sending a multipart @@ -2511,18 +2580,22 @@ (setq just-one (and (= (length e-list) 1) (looking-at "[ \t\n]*") (= (match-end 0) - (vm-extent-start-position (car e-list))) + (extent-start-position (car e-list))) (save-excursion - (goto-char (vm-extent-end-position (car e-list))) + (goto-char (extent-end-position (car e-list))) (looking-at "[ \t\n]*\\'")))) (if (null e-list) (progn (narrow-to-region (point) (point-max)) + ;; support enriched-mode for text/enriched composition + (if enriched + (let ((enriched-initial-annotation "")) + (enriched-encode (point-min) (point-max)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) - (if (vm-xemacs-mule-p) + (if vm-xemacs-mule-p (encode-coding-region (point-min) (point-max) - file-coding-system)) + buffer-file-coding-system)) (setq encoding (vm-determine-proper-content-transfer-encoding (point-min) (point-max)) @@ -2536,16 +2609,24 @@ (vm-reorder-message-headers nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") (insert "MIME-Version: 1.0\n") - (insert "Content-Type: text/plain; charset=" charset "\n") + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) (insert "Content-Transfer-Encoding: " encoding "\n") (vm-add-mail-mode-header-separator)) (while e-list (setq e (car e-list)) - (if (or just-one (= (point) (vm-extent-start-position e))) + (if (or just-one (= (point) (extent-start-position e))) nil - (narrow-to-region (point) (vm-extent-start-position e)) + (narrow-to-region (point) (extent-start-position e)) + (if enriched + (let ((enriched-initial-annotation "")) + (enriched-encode (point-min) (point-max)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) + (if vm-xemacs-mule-p + (encode-coding-region (point-min) (point-max) + buffer-file-coding-system)) (setq encoding (vm-determine-proper-content-transfer-encoding (point-min) (point-max)) @@ -2554,61 +2635,49 @@ (point-max) t)) (setq boundary-positions (cons (point-marker) boundary-positions)) - (insert "Content-Type: text/plain; charset=" charset "\n") + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (widen)) - (goto-char (vm-extent-start-position e)) + (goto-char (extent-start-position e)) (narrow-to-region (point) (point)) - (setq object (vm-extent-property e 'vm-mime-object)) + (setq object (extent-property e 'vm-mime-object)) ;; insert the object (cond ((bufferp object) - (if (vm-xemacs-p) - (insert-buffer-substring object) - ;; as of FSF Emacs 19.34, even with the hooks - ;; we've attached to the attachment overlays, - ;; text STILL can be inserted into them when - ;; font-lock is enabled. Explaining why is - ;; beyond the scope of this comment and I - ;; don't know the answer anyway. This works - ;; to prevent it. - (insert-before-markers " ") - (forward-char -1) - (insert-buffer-substring object) - (delete-char 1))) + (insert-buffer-substring object)) ((stringp object) - (let ((overridding-file-coding-system 'no-conversion)) - (if (vm-xemacs-p) - (insert-file-contents-literally object) - (insert-before-markers " ") - (forward-char -1) - (insert-file-contents-literally object) - (goto-char (point-max)) - (delete-char -1))))) + (let ((coding-system-for-read 'no-conversion) + ;; don't let buffer-file-coding-system be changed + ;; by insert-file-contents-literally. The + ;; value we bind to it to here isn't important. + (buffer-file-coding-system 'no-conversion)) + (insert-file-contents-literally object)))) ;; gather information about the object from the extent. - (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) + (if (setq already-mimed (extent-property e 'vm-mime-encoded)) (setq layout (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") "7bit") - type (or (vm-extent-property e 'vm-mime-type) + type (or (extent-property e 'vm-mime-type) (car (vm-mm-layout-type layout))) - params (or (vm-extent-property e 'vm-mime-parameters) + params (or (extent-property e 'vm-mime-parameters) (cdr (vm-mm-layout-qtype layout))) - description (vm-extent-property e 'vm-mime-description) + description (extent-property e 'vm-mime-description) disposition (if (not (equal - (car (vm-extent-property e 'vm-mime-disposition)) + (car (extent-property e 'vm-mime-disposition)) "unspecified")) - (vm-extent-property e 'vm-mime-disposition) + (extent-property e 'vm-mime-disposition) (vm-mm-layout-qdisposition layout))) - (setq type (vm-extent-property e 'vm-mime-type) - params (vm-extent-property e 'vm-mime-parameters) - description (vm-extent-property e 'vm-mime-description) + (setq type (extent-property e 'vm-mime-type) + params (extent-property e 'vm-mime-parameters) + description (extent-property e 'vm-mime-description) disposition (if (not (equal - (car (vm-extent-property e 'vm-mime-disposition)) + (car (extent-property e 'vm-mime-disposition)) "unspecified")) - (vm-extent-property e 'vm-mime-disposition) + (extent-property e 'vm-mime-disposition) nil))) (cond ((vm-mime-types-match "text" type) (setq encoding @@ -2625,41 +2694,13 @@ (point-max) t)) (setq 8bit (or 8bit (equal encoding "8bit")))) - ((or (vm-mime-types-match "message/rfc822" type) - (vm-mime-types-match "message/news" type) - (vm-mime-types-match "multipart" type)) + ((vm-mime-composite-type-p type) (setq opoint-min (point-min)) (if (not already-mimed) (setq layout (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") "7bit"))) - ;; MIME messages of type "message" and - ;; "multipart" are required to have a non-opaque - ;; content transfer encoding. This means that - ;; if the user only wants to send out 7bit data, - ;; then any subpart that contains 8bit data must - ;; have an opaque (qp or base64) 8->7bit - ;; conversion performed on it so that the - ;; enclosing entity can use an non-opqaue - ;; encoding. - ;; - ;; message/partial requires a "7bit" encoding so - ;; force 8->7 conversion in that case. - (let ((vm-mime-8bit-text-transfer-encoding - (if (vm-mime-types-match "message/partial" type) - 'quoted-printable - vm-mime-8bit-text-transfer-encoding))) - (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout - (vm-mm-layout-parts layout))) - ;; now figure out a proper content trasnfer - ;; encoding value for the enclosing entity. - (re-search-forward "^\n" nil t) - (save-restriction - (narrow-to-region (point) (point-max)) - (setq encoding - (vm-determine-proper-content-transfer-encoding - (point-min) - (point-max)))) + (setq encoding (vm-mime-transfer-encode-layout layout)) (setq 8bit (or 8bit (equal encoding "8bit"))) (goto-char (point-max)) (widen) @@ -2708,11 +2749,11 @@ (goto-char (point-max)) (widen) (save-excursion - (goto-char (vm-extent-start-position e)) + (goto-char (extent-start-position e)) (vm-assert (looking-at "\\[ATTACHMENT"))) - (delete-region (vm-extent-start-position e) - (vm-extent-end-position e)) - (vm-detach-extent e) + (delete-region (extent-start-position e) + (extent-end-position e)) + (detach-extent e) (if (looking-at "\n") (delete-char 1)) (setq e-list (cdr e-list))) @@ -2720,11 +2761,14 @@ ;; extent, if any. (if (or just-one (= (point) (point-max))) nil + (if enriched + (let ((enriched-initial-annotation "")) + (enriched-encode (point) (point-max)))) (setq charset (vm-determine-proper-charset (point) (point-max))) - (if (vm-xemacs-mule-p) - (encode-coding-region (point-min) (point-max) - file-coding-system)) + (if vm-xemacs-mule-p + (encode-coding-region (point) (point-max) + buffer-file-coding-system)) (setq encoding (vm-determine-proper-content-transfer-encoding (point) (point-max)) @@ -2734,7 +2778,9 @@ t)) (setq 8bit (or 8bit (equal encoding "8bit"))) (setq boundary-positions (cons (point-marker) boundary-positions)) - (insert "Content-Type: text/plain; charset=" charset "\n") + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (goto-char (point-max))) (setq boundary (vm-mime-make-multipart-boundary)) @@ -2782,8 +2828,8 @@ (if params (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity params "; ") "\n") - (insert ";\n\t" (mapconcat 'identity params ";\n\t")))) - (insert "\n")) + (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) + (insert "\n"))) (if just-one (and description (insert "Content-Description: " description "\n"))) @@ -2791,10 +2837,325 @@ (progn (insert "Content-Disposition: " (car disposition)) (if (cdr disposition) - (insert ";\n\t" (mapconcat 'identity - (cdr disposition) - ";\n\t"))) - (insert "\n"))) + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity (cdr disposition) "; ") + "\n") + (insert ";\n\t" (mapconcat 'identity (cdr disposition) + ";\n\t"))) + (insert "\n")))) + (if just-one + (insert "Content-Transfer-Encoding: " encoding "\n") + (if 8bit + (insert "Content-Transfer-Encoding: 8bit\n") + (insert "Content-Transfer-Encoding: 7bit\n"))))))) + +(defun vm-mime-fsfemacs-encode-composition () + (save-restriction + (widen) + (if (not (eq major-mode 'mail-mode)) + (error "Command must be used in a VM Mail mode buffer.")) + (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) + (error "Message is already MIME encoded.")) + (let ((8bit nil) + (just-one nil) + (boundary-positions nil) + (enriched (and (boundp 'enriched-mode) enriched-mode)) + already-mimed layout o o-list boundary + type encoding charset params description disposition object + opoint-min) + (mail-text) + (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max)) + o-list (vm-delete (function + (lambda (o) + (overlay-get o 'vm-mime-object))) + o-list t) + o-list (sort o-list (function + (lambda (e1 e2) + (< (overlay-end e1) + (overlay-end e2)))))) + ;; If there's just one attachment and no other readable + ;; text in the buffer then make the message type just be + ;; the attachment type rather than sending a multipart + ;; message with one attachment + (setq just-one (and (= (length o-list) 1) + (looking-at "[ \t\n]*") + (= (match-end 0) + (overlay-start (car o-list))) + (save-excursion + (goto-char (overlay-end (car o-list))) + (looking-at "[ \t\n]*\\'")))) + (if (null o-list) + (progn + (narrow-to-region (point) (point-max)) + ;; support enriched-mode for text/enriched composition + (if enriched + (let ((enriched-initial-annotation "")) + (enriched-encode (point-min) (point-max)))) + (setq charset (vm-determine-proper-charset (point-min) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point-min) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point-min) + (point-max) + t)) + (widen) + (vm-remove-mail-mode-header-separator) + (goto-char (point-min)) + (vm-reorder-message-headers + nil nil "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") + (insert "MIME-Version: 1.0\n") + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) + (insert "Content-Transfer-Encoding: " encoding "\n") + (vm-add-mail-mode-header-separator)) + (while o-list + (setq o (car o-list)) + (if (or just-one (= (point) (overlay-start o))) + nil + (narrow-to-region (point) (overlay-start o)) + ;; support enriched-mode for text/enriched composition + (if enriched + (let ((enriched-initial-annotation "")) + (save-excursion + ;; insert/delete trick needed to avoid + ;; enriched-mode tags from seeping into the + ;; attachment overlays. I really wish + ;; front-advance / rear-advance overlay + ;; endpoint properties actually worked. + (goto-char (point-max)) + (insert-before-markers "\n") + (enriched-encode (point-min) (1- (point))) + (goto-char (point-max)) + (delete-char -1) + '(goto-char (point-min))))) + (setq charset (vm-determine-proper-charset (point-min) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point-min) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point-min) + (point-max) + t)) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) + (insert "Content-Transfer-Encoding: " encoding "\n\n") + (widen)) + (goto-char (overlay-start o)) + (narrow-to-region (point) (point)) + (setq object (overlay-get o 'vm-mime-object)) + ;; insert the object + (cond ((bufferp object) + ;; as of FSF Emacs 19.34, even with the hooks + ;; we've attached to the attachment overlays, + ;; text STILL can be inserted into them when + ;; font-lock is enabled. Explaining why is + ;; beyond the scope of this comment and I + ;; don't know the answer anyway. This works + ;; to prevent it. + (insert-before-markers " ") + (forward-char -1) + (insert-buffer-substring object) + (delete-char 1)) + ((stringp object) + (insert-before-markers " ") + (forward-char -1) + (insert-file-contents object) + (goto-char (point-max)) + (delete-char -1))) + ;; gather information about the object from the extent. + (if (setq already-mimed (overlay-get o 'vm-mime-encoded)) + (setq layout (vm-mime-parse-entity + nil (list "text/plain" "charset=us-ascii") + "7bit") + type (or (overlay-get o 'vm-mime-type) + (car (vm-mm-layout-type layout))) + params (or (overlay-get o 'vm-mime-parameters) + (cdr (vm-mm-layout-qtype layout))) + description (overlay-get o 'vm-mime-description) + disposition + (if (not + (equal + (car (overlay-get o 'vm-mime-disposition)) + "unspecified")) + (overlay-get o 'vm-mime-disposition) + (vm-mm-layout-qdisposition layout))) + (setq type (overlay-get o 'vm-mime-type) + params (overlay-get o 'vm-mime-parameters) + description (overlay-get o 'vm-mime-description) + disposition + (if (not (equal + (car (overlay-get o 'vm-mime-disposition)) + "unspecified")) + (overlay-get o 'vm-mime-disposition) + nil))) + (cond ((vm-mime-types-match "text" type) + (setq encoding + (vm-determine-proper-content-transfer-encoding + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max)) + encoding (vm-mime-transfer-encode-region + encoding + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max) + t)) + (setq 8bit (or 8bit (equal encoding "8bit")))) + ((vm-mime-composite-type-p type) + (setq opoint-min (point-min)) + (if (not already-mimed) + (setq layout (vm-mime-parse-entity + nil (list "text/plain" "charset=us-ascii") + "7bit"))) + (setq encoding (vm-mime-transfer-encode-layout layout)) + (setq 8bit (or 8bit (equal encoding "8bit"))) + (goto-char (point-max)) + (widen) + (narrow-to-region opoint-min (point))) + (t + (vm-mime-base64-encode-region + (if already-mimed + (vm-mm-layout-body-start layout) + (point-min)) + (point-max)) + (setq encoding "base64"))) + (if just-one + nil + (goto-char (point-min)) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (if (not already-mimed) + nil + ;; trim headers + (vm-reorder-message-headers + nil (nconc (list "Content-Disposition:" "Content-ID:") + (if description + (list "Content-Description:") + nil)) + nil) + ;; remove header/text separator + (goto-char (1- (vm-mm-layout-body-start layout))) + (if (looking-at "\n") + (delete-char 1))) + (insert "Content-Type: " type) + (if params + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity params "; ") "\n") + (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) + (insert "\n")) + (and description + (insert "Content-Description: " description "\n")) + (if disposition + (progn + (insert "Content-Disposition: " (car disposition)) + (if (cdr disposition) + (insert ";\n\t" (mapconcat 'identity + (cdr disposition) + ";\n\t"))) + (insert "\n"))) + (insert "Content-Transfer-Encoding: " encoding "\n\n")) + (goto-char (point-max)) + (widen) + (save-excursion + (goto-char (overlay-start o)) + (vm-assert (looking-at "\\[ATTACHMENT"))) + (delete-region (overlay-start o) + (overlay-end o)) + (delete-overlay o) + (if (looking-at "\n") + (delete-char 1)) + (setq o-list (cdr o-list))) + ;; handle the remaining chunk of text after the last + ;; extent, if any. + (if (or just-one (= (point) (point-max))) + nil + ;; support enriched-mode for text/enriched composition + (if enriched + (let ((enriched-initial-annotation "")) + (enriched-encode (point) (point-max)))) + (setq charset (vm-determine-proper-charset (point) + (point-max))) + (setq encoding (vm-determine-proper-content-transfer-encoding + (point) + (point-max)) + encoding (vm-mime-transfer-encode-region encoding + (point) + (point-max) + t)) + (setq 8bit (or 8bit (equal encoding "8bit"))) + (setq boundary-positions (cons (point-marker) boundary-positions)) + (if enriched + (insert "Content-Type: text/enriched; charset=" charset "\n") + (insert "Content-Type: text/plain; charset=" charset "\n")) + (insert "Content-Transfer-Encoding: " encoding "\n\n") + (goto-char (point-max))) + (setq boundary (vm-mime-make-multipart-boundary)) + (mail-text) + (while (re-search-forward (concat "^--" + (regexp-quote boundary) + "\\(--\\)?$") + nil t) + (setq boundary (vm-mime-make-multipart-boundary)) + (mail-text)) + (goto-char (point-max)) + (or just-one (insert "\n--" boundary "--\n")) + (while boundary-positions + (goto-char (car boundary-positions)) + (insert "\n--" boundary "\n") + (setq boundary-positions (cdr boundary-positions))) + (if (and just-one already-mimed) + (progn + (goto-char (vm-mm-layout-header-start layout)) + ;; trim headers + (vm-reorder-message-headers + nil '("Content-Description:" "Content-ID:") nil) + ;; remove header/text separator + (goto-char (1- (vm-mm-layout-body-start layout))) + (if (looking-at "\n") + (delete-char 1)) + ;; copy remainder to enclosing entity's header section + (insert-buffer-substring (current-buffer) + (vm-mm-layout-header-start layout) + (vm-mm-layout-body-start layout)) + (delete-region (vm-mm-layout-header-start layout) + (vm-mm-layout-body-start layout)))) + (goto-char (point-min)) + (vm-remove-mail-mode-header-separator) + (vm-reorder-message-headers + nil nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") + (vm-add-mail-mode-header-separator) + (insert "MIME-Version: 1.0\n") + (if (not just-one) + (insert (if vm-mime-avoid-folding-content-type + "Content-Type: multipart/mixed; boundary=\"" + "Content-Type: multipart/mixed;\n\tboundary=\"") + boundary "\"\n") + (insert "Content-Type: " type) + (if params + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity params "; ") "\n") + (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) + (insert "\n"))) + (if just-one + (and description + (insert "Content-Description: " description "\n"))) + (if (and just-one disposition) + (progn + (insert "Content-Disposition: " (car disposition)) + (if (cdr disposition) + (if vm-mime-avoid-folding-content-type + (insert "; " (mapconcat 'identity (cdr disposition) "; ") + "\n") + (insert ";\n\t" (mapconcat 'identity (cdr disposition) + ";\n\t"))) + (insert "\n")))) (if just-one (insert "Content-Transfer-Encoding: " encoding "\n") (if 8bit @@ -2812,16 +3173,15 @@ b header-start header-end master-buffer start end) (vm-remove-mail-mode-header-separator) ;; message/partial must have "7bit" content transfer - ;; encoding, so verify that everything has been encoded for + ;; encoding, so force everything to be encoded for ;; 7bit transmission. (let ((vm-mime-8bit-text-transfer-encoding - (if (eq vm-mime-8bit-text-transfer-encoding 'send) + (if (eq vm-mime-8bit-text-transfer-encoding '8bit) 'quoted-printable vm-mime-8bit-text-transfer-encoding))) - (vm-mime-map-atomic-layouts - 'vm-mime-transfer-encode-layout - (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") - "7bit")))) + (vm-mime-transfer-encode-layout + (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") + "7bit"))) (goto-char (point-min)) (setq header-start (point)) (search-forward "\n\n") @@ -2864,6 +3224,7 @@ (vm-increment n) (set-buffer master-buffer) (setq start (point))) + (vm-add-mail-mode-header-separator) (message "Fragmenting message... done") (nreverse buffers)))) @@ -2878,13 +3239,15 @@ (error "Command must be used in a VM Mail mode buffer.")) (let ((temp-buffer nil) (mail-buffer (current-buffer)) + (enriched (and (boundp 'enriched-mode) enriched-mode)) e-list) (unwind-protect (progn (setq temp-buffer (generate-new-buffer "composition preview")) (set-buffer temp-buffer) - ;; so vm-mime-encode-composition won't complain + ;; so vm-mime-xxxx-encode-composition won't complain (setq major-mode 'mail-mode) + (set (make-local-variable 'enriched-mode) enriched) (vm-insert-region-from-buffer mail-buffer) (goto-char (point-min)) (or (vm-mail-mode-get-header-contents "From") @@ -2899,6 +3262,7 @@ (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:")) (vm-mime-encode-composition)) + (vm-remove-mail-mode-header-separator) (goto-char (point-min)) (insert (vm-leading-message-separator 'From_)) (goto-char (point-max)) @@ -2921,12 +3285,16 @@ (and temp-buffer (kill-buffer temp-buffer))))) (defun vm-mime-composite-type-p (type) - (or (vm-mime-types-match "message" type) + (or (and (vm-mime-types-match "message" type) + (not (vm-mime-types-match "message/partial" type)) + (not (vm-mime-types-match "message/external-body" type))) (vm-mime-types-match "multipart" type))) -(defun vm-mime-map-atomic-layouts (function list) - (while list - (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) - (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) - (funcall function (car list))) - (setq list (cdr list)))) +;; Unused currrently. +;; +;;(defun vm-mime-map-atomic-layouts (function list) +;; (while list +;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) +;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) +;; (funcall function (car list))) +;; (setq list (cdr list))))