Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mime.el @ 26:441bb1e64a06 r19-15b96

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b96
author cvs
date Mon, 13 Aug 2007 08:51:32 +0200
parents 4103f0995bd7
children ec9a17fef872
comparison
equal deleted inserted replaced
25:383a494979f8 26:441bb1e64a06
151 ((string-match "^quoted-printable$" 151 ((string-match "^quoted-printable$"
152 (vm-mm-layout-encoding layout)) 152 (vm-mm-layout-encoding layout))
153 (vm-mime-qp-decode-region start end))))) 153 (vm-mime-qp-decode-region start end)))))
154 154
155 (defun vm-mime-base64-decode-region (start end &optional crlf) 155 (defun vm-mime-base64-decode-region (start end &optional crlf)
156 (vm-unsaved-message "Decoding base64...") 156 (message "Decoding base64...")
157 (let ((work-buffer nil) 157 (let ((work-buffer nil)
158 (done nil) 158 (done nil)
159 (counter 0) 159 (counter 0)
160 (bits 0) 160 (bits 0)
161 (lim 0) inputpos 161 (lim 0) inputpos
217 (or (markerp end) (setq end (vm-marker end))) 217 (or (markerp end) (setq end (vm-marker end)))
218 (goto-char start) 218 (goto-char start)
219 (insert-buffer-substring work-buffer) 219 (insert-buffer-substring work-buffer)
220 (delete-region (point) end)) 220 (delete-region (point) end))
221 (and work-buffer (kill-buffer work-buffer)))) 221 (and work-buffer (kill-buffer work-buffer))))
222 (vm-unsaved-message "Decoding base64... done")) 222 (message "Decoding base64... done"))
223 223
224 (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding) 224 (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding)
225 (and (> (- end start) 200) 225 (and (> (- end start) 200)
226 (vm-unsaved-message "Encoding base64...")) 226 (message "Encoding base64..."))
227 (let ((work-buffer nil) 227 (let ((work-buffer nil)
228 (counter 0) 228 (counter 0)
229 (cols 0) 229 (cols 0)
230 (bits 0) 230 (bits 0)
231 (alphabet vm-mime-base64-alphabet) 231 (alphabet vm-mime-base64-alphabet)
242 (let ((status (apply 'vm-run-command-on-region 242 (let ((status (apply 'vm-run-command-on-region
243 start end work-buffer 243 start end work-buffer
244 vm-mime-base64-encoder-program 244 vm-mime-base64-encoder-program
245 vm-mime-base64-encoder-switches))) 245 vm-mime-base64-encoder-switches)))
246 (if (not (eq status t)) 246 (if (not (eq status t))
247 (vm-mime-error "%s" (cdr status)))) 247 (vm-mime-error "%s" (cdr status)))
248 (if B-encoding
249 (progn
250 ;; if we're B encoding, strip out the line breaks
251 (goto-char (point-min))
252 (while (search-forward "\n" nil t)
253 (delete-char -1)))))
248 (setq inputpos start) 254 (setq inputpos start)
249 (while (< inputpos end) 255 (while (< inputpos end)
250 (setq bits (+ bits (char-after inputpos))) 256 (setq bits (+ bits (char-after inputpos)))
251 (vm-increment counter) 257 (vm-increment counter)
252 (cond ((= counter 3) 258 (cond ((= counter 3)
284 (or (markerp end) (setq end (vm-marker end))) 290 (or (markerp end) (setq end (vm-marker end)))
285 (goto-char start) 291 (goto-char start)
286 (insert-buffer-substring work-buffer) 292 (insert-buffer-substring work-buffer)
287 (delete-region (point) end) 293 (delete-region (point) end)
288 (and (> (- end start) 200) 294 (and (> (- end start) 200)
289 (vm-unsaved-message "Encoding base64... done")) 295 (message "Encoding base64... done"))
290 (- end start)) 296 (- end start))
291 (and work-buffer (kill-buffer work-buffer))))) 297 (and work-buffer (kill-buffer work-buffer)))))
292 298
293 (defun vm-mime-qp-decode-region (start end) 299 (defun vm-mime-qp-decode-region (start end)
294 (and (> (- end start) 200) 300 (and (> (- end start) 200)
295 (vm-unsaved-message "Decoding quoted-printable...")) 301 (message "Decoding quoted-printable..."))
296 (let ((work-buffer nil) 302 (let ((work-buffer nil)
297 (buf (current-buffer)) 303 (buf (current-buffer))
298 (case-fold-search nil) 304 (case-fold-search nil)
299 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) 305 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
300 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) 306 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
352 (goto-char start) 358 (goto-char start)
353 (insert-buffer-substring work-buffer) 359 (insert-buffer-substring work-buffer)
354 (delete-region (point) end)) 360 (delete-region (point) end))
355 (and work-buffer (kill-buffer work-buffer)))) 361 (and work-buffer (kill-buffer work-buffer))))
356 (and (> (- end start) 200) 362 (and (> (- end start) 200)
357 (vm-unsaved-message "Decoding quoted-printable... done"))) 363 (message "Decoding quoted-printable... done")))
358 364
359 (defun vm-mime-qp-encode-region (start end &optional Q-encoding) 365 (defun vm-mime-qp-encode-region (start end &optional Q-encoding)
360 (and (> (- end start) 200) 366 (and (> (- end start) 200)
361 (vm-unsaved-message "Encoding quoted-printable...")) 367 (message "Encoding quoted-printable..."))
362 (let ((work-buffer nil) 368 (let ((work-buffer nil)
363 (buf (current-buffer)) 369 (buf (current-buffer))
364 (cols 0) 370 (cols 0)
365 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) 371 (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3)
366 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) 372 (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7)
400 (or (markerp end) (setq end (vm-marker end))) 406 (or (markerp end) (setq end (vm-marker end)))
401 (goto-char start) 407 (goto-char start)
402 (insert-buffer-substring work-buffer) 408 (insert-buffer-substring work-buffer)
403 (delete-region (point) end) 409 (delete-region (point) end)
404 (and (> (- end start) 200) 410 (and (> (- end start) 200)
405 (vm-unsaved-message "Encoding quoted-printable... done")) 411 (message "Encoding quoted-printable... done"))
406 (- end start)) 412 (- end start))
407 (and work-buffer (kill-buffer work-buffer))))) 413 (and work-buffer (kill-buffer work-buffer)))))
408 414
409 (defun vm-decode-mime-message-headers (m) 415 (defun vm-decode-mime-message-headers (m)
410 (let ((case-fold-search t) 416 (let ((case-fold-search t)
478 (setq charset (get-text-property start 'vm-charset)) 484 (setq charset (get-text-property start 'vm-charset))
479 (setq pos (next-single-property-change start 'vm-charset)) 485 (setq pos (next-single-property-change start 'vm-charset))
480 (or pos (setq pos (point-max) done t)) 486 (or pos (setq pos (point-max) done t))
481 (if charset 487 (if charset
482 (progn 488 (progn
483 (message " pos = %d start = %d" pos start)
484 (if (setq coding (get-text-property start 'vm-coding)) 489 (if (setq coding (get-text-property start 'vm-coding))
485 (progn 490 (progn
486 (setq old-size (buffer-size)) 491 (setq old-size (buffer-size))
487 (encode-coding-region start pos coding) 492 (encode-coding-region start pos coding)
488 (setq pos (+ pos (- (buffer-size) old-size))))) 493 (setq pos (+ pos (- (buffer-size) old-size)))))
489 (message " pos = %d start = %d" pos start)
490 (setq pos 494 (setq pos
491 (+ start 495 (+ start
492 (if (setq q-encoding 496 (if (setq q-encoding
493 (string-match "^iso-8859-\\|^us-ascii" 497 (string-match "^iso-8859-\\|^us-ascii"
494 charset)) 498 charset))
495 (vm-mime-Q-encode-region start pos) 499 (vm-mime-Q-encode-region start pos)
496 (vm-mime-B-encode-region start pos)))) 500 (vm-mime-B-encode-region start pos))))
497 (message " pos = %d start = %d" pos start)
498 (goto-char pos) 501 (goto-char pos)
499 (insert "?=") 502 (insert "?=")
500 (setq pos (point)) 503 (setq pos (point))
501 (goto-char start) 504 (goto-char start)
502 (insert "=?" charset "?" (if q-encoding "Q" "B") "?"))) 505 (insert "=?" charset "?" (if q-encoding "Q" "B") "?")))
603 606
604 (defun vm-mime-parse-entity (&optional m default-type default-encoding) 607 (defun vm-mime-parse-entity (&optional m default-type default-encoding)
605 (let ((case-fold-search t) version type qtype encoding id description 608 (let ((case-fold-search t) version type qtype encoding id description
606 disposition qdisposition boundary boundary-regexp start 609 disposition qdisposition boundary boundary-regexp start
607 multipart-list c-t c-t-e done p returnval) 610 multipart-list c-t c-t-e done p returnval)
608 (and m (vm-unsaved-message "Parsing MIME message...")) 611 (and m (message "Parsing MIME message..."))
609 (prog1 612 (prog1
610 (catch 'return-value 613 (catch 'return-value
611 (save-excursion 614 (save-excursion
612 (if m 615 (if m
613 (progn 616 (progn
786 (vm-marker (point-min)) 789 (vm-marker (point-min))
787 (vm-marker (point)) 790 (vm-marker (point))
788 (vm-marker (point-max)) 791 (vm-marker (point-max))
789 (nreverse multipart-list) 792 (nreverse multipart-list)
790 nil ))))) 793 nil )))))
791 (and m (vm-unsaved-message "Parsing MIME message... done")) 794 (and m (message "Parsing MIME message... done"))
792 ))) 795 )))
793 796
794 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) 797 (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e)
795 (or c-t (setq c-t '("text/plain" "charset=us-ascii"))) 798 (or c-t (setq c-t '("text/plain" "charset=us-ascii")))
796 ;; don't let subpart parse errors make the whole parse fail. use default 799 ;; don't let subpart parse errors make the whole parse fail. use default
880 ;; Default to binary file type for DOS/NT. 883 ;; Default to binary file type for DOS/NT.
881 buffer-file-type t 884 buffer-file-type t
882 ;; Tell XEmacs/MULE not to mess with the text on writes. 885 ;; Tell XEmacs/MULE not to mess with the text on writes.
883 buffer-read-only t 886 buffer-read-only t
884 mode-line-format vm-mode-line-format) 887 mode-line-format vm-mode-line-format)
885 (and (fboundp 'set-file-coding-system) 888 (and (vm-xemacs-mule-p)
886 (set-file-coding-system 'binary t)) 889 (set-file-coding-system 'binary t))
887 (cond ((vm-fsfemacs-19-p) 890 (cond ((vm-fsfemacs-19-p)
888 ;; need to do this outside the let because 891 ;; need to do this outside the let because
889 ;; loading disp-table initializes 892 ;; loading disp-table initializes
890 ;; standard-display-table. 893 ;; standard-display-table.
1077 (t (setq alist (cdr alist))))) 1080 (t (setq alist (cdr alist)))))
1078 (and alist (car alist)))) 1081 (and alist (car alist))))
1079 1082
1080 (defun vm-mime-convert-undisplayable-layout (layout) 1083 (defun vm-mime-convert-undisplayable-layout (layout)
1081 (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout))))) 1084 (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout)))))
1082 (vm-unsaved-message "Converting %s to %s..." 1085 (message "Converting %s to %s..."
1083 (car (vm-mm-layout-type layout)) 1086 (car (vm-mm-layout-type layout))
1084 (nth 1 ooo)) 1087 (nth 1 ooo))
1085 (save-excursion 1088 (save-excursion
1086 (set-buffer (generate-new-buffer " *mime object*")) 1089 (set-buffer (generate-new-buffer " *mime object*"))
1087 (setq vm-message-garbage-alist 1090 (setq vm-message-garbage-alist
1093 t t nil shell-command-switch (nth 2 ooo)) 1096 t t nil shell-command-switch (nth 2 ooo))
1094 (goto-char (point-min)) 1097 (goto-char (point-min))
1095 (insert "Content-Type: " (nth 1 ooo) "\n") 1098 (insert "Content-Type: " (nth 1 ooo) "\n")
1096 (insert "Content-Transfer-Encoding: binary\n\n") 1099 (insert "Content-Transfer-Encoding: binary\n\n")
1097 (set-buffer-modified-p nil) 1100 (set-buffer-modified-p nil)
1098 (vm-unsaved-message "Converting %s to %s... done" 1101 (message "Converting %s to %s... done"
1099 (car (vm-mm-layout-type layout)) 1102 (car (vm-mm-layout-type layout))
1100 (nth 1 ooo)) 1103 (nth 1 ooo))
1101 (vector (list (nth 1 ooo)) 1104 (vector (list (nth 1 ooo))
1102 (list (nth 1 ooo)) 1105 (list (nth 1 ooo))
1103 "binary" 1106 "binary"
1218 (vm-auto-decode-mime-messages nil)) 1221 (vm-auto-decode-mime-messages nil))
1219 (intern (buffer-name) vm-buffers-needing-display-update) 1222 (intern (buffer-name) vm-buffers-needing-display-update)
1220 (vm-preview-current-message))) 1223 (vm-preview-current-message)))
1221 (let ((layout (vm-mm-layout (car vm-message-pointer))) 1224 (let ((layout (vm-mm-layout (car vm-message-pointer)))
1222 (m (car vm-message-pointer))) 1225 (m (car vm-message-pointer)))
1223 (vm-unsaved-message "Decoding MIME message...") 1226 (message "Decoding MIME message...")
1224 (cond ((stringp layout) 1227 (cond ((stringp layout)
1225 (error "Invalid MIME message: %s" layout))) 1228 (error "Invalid MIME message: %s" layout)))
1226 (if (vm-mime-plain-message-p m) 1229 (if (vm-mime-plain-message-p m)
1227 (error "Message needs no decoding.")) 1230 (error "Message needs no decoding."))
1228 (or vm-presentation-buffer 1231 (or vm-presentation-buffer
1249 (set-buffer-modified-p modified)))) 1252 (set-buffer-modified-p modified))))
1250 (save-excursion (set-buffer vm-mail-buffer) 1253 (save-excursion (set-buffer vm-mail-buffer)
1251 (setq vm-mime-decoded 'decoded)) 1254 (setq vm-mime-decoded 'decoded))
1252 (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) 1255 (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update)
1253 (vm-update-summary-and-mode-line) 1256 (vm-update-summary-and-mode-line)
1254 (vm-unsaved-message "Decoding MIME message... done")))) 1257 (message "Decoding MIME message... done"))))
1255 (vm-display nil nil '(vm-decode-mime-message) 1258 (vm-display nil nil '(vm-decode-mime-message)
1256 '(vm-decode-mime-message reading-message))) 1259 '(vm-decode-mime-message reading-message)))
1257 1260
1258 (defun vm-decode-mime-layout (layout &optional dont-honor-c-d) 1261 (defun vm-decode-mime-layout (layout &optional dont-honor-c-d)
1259 (let ((modified (buffer-modified-p)) type type-no-subtype (extent nil)) 1262 (let ((modified (buffer-modified-p)) type type-no-subtype (extent nil))
1320 ;; of executing arbitrary Emacs-Lisp code embedded in a page. 1323 ;; of executing arbitrary Emacs-Lisp code embedded in a page.
1321 ;; 1324 ;;
1322 ;;(defun vm-mime-display-internal-text/html (layout) 1325 ;;(defun vm-mime-display-internal-text/html (layout)
1323 ;; (let ((buffer-read-only nil) 1326 ;; (let ((buffer-read-only nil)
1324 ;; (work-buffer nil)) 1327 ;; (work-buffer nil))
1325 ;; (vm-unsaved-message "Inlining text/html, be patient...") 1328 ;; (message "Inlining text/html, be patient...")
1326 ;; ;; w3-region is not as tame as we would like. 1329 ;; ;; w3-region is not as tame as we would like.
1327 ;; ;; make sure the yoke is firmly attached. 1330 ;; ;; make sure the yoke is firmly attached.
1328 ;; (unwind-protect 1331 ;; (unwind-protect
1329 ;; (progn 1332 ;; (progn
1330 ;; (save-excursion 1333 ;; (save-excursion
1335 ;; (save-excursion 1338 ;; (save-excursion
1336 ;; (save-window-excursion 1339 ;; (save-window-excursion
1337 ;; (w3-region (point-min) (point-max))))) 1340 ;; (w3-region (point-min) (point-max)))))
1338 ;; (insert-buffer-substring work-buffer)) 1341 ;; (insert-buffer-substring work-buffer))
1339 ;; (and work-buffer (kill-buffer work-buffer))) 1342 ;; (and work-buffer (kill-buffer work-buffer)))
1340 ;; (vm-unsaved-message "Inlining text/html... done") 1343 ;; (message "Inlining text/html... done")
1341 ;; t )) 1344 ;; t ))
1342 1345
1343 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) 1346 (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls)
1344 (let ((start (point)) end old-size 1347 (let ((start (point)) end old-size
1345 (buffer-read-only nil) 1348 (buffer-read-only nil)
1359 (defun vm-mime-display-internal-text/enriched (layout) 1362 (defun vm-mime-display-internal-text/enriched (layout)
1360 (require 'enriched) 1363 (require 'enriched)
1361 (let ((start (point)) end 1364 (let ((start (point)) end
1362 (buffer-read-only nil) 1365 (buffer-read-only nil)
1363 (enriched-verbose t)) 1366 (enriched-verbose t))
1364 (vm-unsaved-message "Decoding text/enriched, be patient...") 1367 (message "Decoding text/enriched, be patient...")
1365 (vm-mime-insert-mime-body layout) 1368 (vm-mime-insert-mime-body layout)
1366 (setq end (point-marker)) 1369 (setq end (point-marker))
1367 (vm-mime-transfer-decode-region layout start end) 1370 (vm-mime-transfer-decode-region layout start end)
1368 ;; enriched-decode expects a couple of headers at the top of 1371 ;; enriched-decode expects a couple of headers at the top of
1369 ;; the region and will remove anything that looks like a 1372 ;; the region and will remove anything that looks like a
1372 (goto-char start) 1375 (goto-char start)
1373 (insert "Comment: You should not see this header\n\n") 1376 (insert "Comment: You should not see this header\n\n")
1374 (enriched-decode start end) 1377 (enriched-decode start end)
1375 (vm-energize-urls-in-message-region start end) 1378 (vm-energize-urls-in-message-region start end)
1376 (goto-char end) 1379 (goto-char end)
1377 (vm-unsaved-message "Decoding text/enriched... done") 1380 (message "Decoding text/enriched... done")
1378 t )) 1381 t ))
1379 1382
1380 (defun vm-mime-display-external-generic (layout) 1383 (defun vm-mime-display-external-generic (layout)
1381 (let ((program-list (vm-mime-find-external-viewer 1384 (let ((program-list (vm-mime-find-external-viewer
1382 (car (vm-mm-layout-type layout)))) 1385 (car (vm-mm-layout-type layout))))
1396 file-coding-system) 1399 file-coding-system)
1397 ;; Tell DOS/Windows NT whether the file is binary 1400 ;; Tell DOS/Windows NT whether the file is binary
1398 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1401 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1399 ;; Tell XEmacs/MULE not to mess with the bits unless 1402 ;; Tell XEmacs/MULE not to mess with the bits unless
1400 ;; this is a text type. 1403 ;; this is a text type.
1401 (if (fboundp 'set-file-coding-system) 1404 (if (vm-xemacs-mule-p)
1402 (if (vm-mime-text-type-p layout) 1405 (if (vm-mime-text-type-p layout)
1403 (set-file-coding-system 'no-conversion nil) 1406 (set-file-coding-system 'no-conversion nil)
1404 (set-file-coding-system 'binary t))) 1407 (set-file-coding-system 'binary t)))
1405 (write-region start end tempfile nil 0)) 1408 (write-region start end tempfile nil 0))
1406 (delete-region start end) 1409 (delete-region start end)
1407 (save-excursion 1410 (save-excursion
1408 (vm-select-folder-buffer) 1411 (vm-select-folder-buffer)
1409 (setq vm-folder-garbage-alist 1412 (setq vm-folder-garbage-alist
1410 (cons (cons tempfile 'delete-file) 1413 (cons (cons tempfile 'delete-file)
1411 vm-folder-garbage-alist))))) 1414 vm-folder-garbage-alist)))))
1412 (vm-unsaved-message "Launching %s..." (mapconcat 'identity 1415 (message "Launching %s..." (mapconcat 'identity
1413 program-list 1416 program-list
1414 " ")) 1417 " "))
1415 (setq process 1418 (setq process
1416 (apply 'start-process 1419 (apply 'start-process
1417 (format "view %25s" (vm-mime-layout-description layout)) 1420 (format "view %25s" (vm-mime-layout-description layout))
1418 nil (append program-list (list tempfile)))) 1421 nil (append program-list (list tempfile))))
1419 (process-kill-without-query process t) 1422 (process-kill-without-query process t)
1420 (vm-unsaved-message "Launching %s... done" (mapconcat 'identity 1423 (message "Launching %s... done" (mapconcat 'identity
1421 program-list 1424 program-list
1422 " ")) 1425 " "))
1423 (save-excursion 1426 (save-excursion
1424 (vm-select-folder-buffer) 1427 (vm-select-folder-buffer)
1425 (setq vm-message-garbage-alist 1428 (setq vm-message-garbage-alist
1615 (function 1618 (function
1616 (lambda (layout) 1619 (lambda (layout)
1617 (save-excursion 1620 (save-excursion
1618 (vm-mime-display-internal-message/partial layout)))) 1621 (vm-mime-display-internal-message/partial layout))))
1619 layout nil)) 1622 layout nil))
1620 (vm-unsaved-message "Assembling message...") 1623 (message "Assembling message...")
1621 (let ((parts nil) 1624 (let ((parts nil)
1622 (missing nil) 1625 (missing nil)
1623 (work-buffer nil) 1626 (work-buffer nil)
1624 extent id o number total m i prev part-header-pos 1627 extent id o number total m i prev part-header-pos
1625 p-id p-number p-total p-list) 1628 p-id p-number p-total p-list)
1719 (goto-char (point-min)) 1722 (goto-char (point-min))
1720 (insert (vm-leading-message-separator)) 1723 (insert (vm-leading-message-separator))
1721 (goto-char (point-max)) 1724 (goto-char (point-max))
1722 (insert (vm-trailing-message-separator)) 1725 (insert (vm-trailing-message-separator))
1723 (set-buffer-modified-p nil) 1726 (set-buffer-modified-p nil)
1724 (vm-unsaved-message "Assembling message... done") 1727 (message "Assembling message... done")
1725 (vm-save-buffer-excursion 1728 (vm-save-buffer-excursion
1726 (vm-goto-new-folder-frame-maybe 'folder) 1729 (vm-goto-new-folder-frame-maybe 'folder)
1727 (vm-mode)) 1730 (vm-mode))
1728 ;; temp buffer, don't offer to save it. 1731 ;; temp buffer, don't offer to save it.
1729 (setq buffer-offer-save nil) 1732 (setq buffer-offer-save nil)
1745 (setq end (point-marker)) 1748 (setq end (point-marker))
1746 (vm-mime-transfer-decode-region layout start end) 1749 (vm-mime-transfer-decode-region layout start end)
1747 (setq tempfile (vm-make-tempfile-name)) 1750 (setq tempfile (vm-make-tempfile-name))
1748 ;; coding system for presentation buffer is binary 1751 ;; coding system for presentation buffer is binary
1749 (write-region start end tempfile nil 0) 1752 (write-region start end tempfile nil 0)
1750 (vm-unsaved-message "Creating %s glyph..." name) 1753 (message "Creating %s glyph..." name)
1751 (setq g (make-glyph 1754 (setq g (make-glyph
1752 (list (vector feature ':file tempfile) 1755 (list (vector feature ':file tempfile)
1753 (vector 'string 1756 (vector 'string
1754 ':data 1757 ':data
1755 (format "[Unknown %s image encoding]\n" 1758 (format "[Unknown %s image encoding]\n"
1756 name))))) 1759 name)))))
1757 (vm-unsaved-message "") 1760 (message "")
1758 (vm-set-mm-layout-cache layout g) 1761 (vm-set-mm-layout-cache layout g)
1759 (save-excursion 1762 (save-excursion
1760 (vm-select-folder-buffer) 1763 (vm-select-folder-buffer)
1761 (setq vm-folder-garbage-alist 1764 (setq vm-folder-garbage-alist
1762 (cons (cons tempfile 'delete-file) 1765 (cons (cons tempfile 'delete-file)
1965 (set-buffer work-buffer) 1968 (set-buffer work-buffer)
1966 ;; Tell DOS/Windows NT whether the file is binary 1969 ;; Tell DOS/Windows NT whether the file is binary
1967 (setq buffer-file-type (not (vm-mime-text-type-p layout))) 1970 (setq buffer-file-type (not (vm-mime-text-type-p layout)))
1968 ;; Tell XEmacs/MULE not to mess with the bits unless 1971 ;; Tell XEmacs/MULE not to mess with the bits unless
1969 ;; this is a text type. 1972 ;; this is a text type.
1970 (if (fboundp 'set-file-coding-system) 1973 (if (vm-xemacs-mule-p)
1971 (if (vm-mime-text-type-p layout) 1974 (if (vm-mime-text-type-p layout)
1972 (set-file-coding-system 'no-conversion nil) 1975 (set-file-coding-system 'no-conversion nil)
1973 (set-file-coding-system 'binary t))) 1976 (set-file-coding-system 'binary t)))
1974 (vm-mime-insert-mime-body layout) 1977 (vm-mime-insert-mime-body layout)
1975 (vm-mime-transfer-decode-region layout (point-min) (point-max)) 1978 (vm-mime-transfer-decode-region layout (point-min) (point-max))
2034 (replace-match " ")) 2037 (replace-match " "))
2035 (buffer-string)) 2038 (buffer-string))
2036 (and work-buffer (kill-buffer work-buffer)))))) 2039 (and work-buffer (kill-buffer work-buffer))))))
2037 2040
2038 (defun vm-mime-layout-description (layout) 2041 (defun vm-mime-layout-description (layout)
2039 (if (vm-mm-layout-description layout) 2042 (let ((type (car (vm-mm-layout-type layout)))
2040 (vm-mime-scrub-description (vm-mm-layout-description layout)) 2043 description name)
2041 (let ((type (car (vm-mm-layout-type layout))) 2044 (setq description
2042 name) 2045 (if (vm-mm-layout-description layout)
2043 (cond ((vm-mime-types-match "multipart/digest" type) 2046 (vm-mime-scrub-description (vm-mm-layout-description layout))))
2044 (let ((n (length (vm-mm-layout-parts layout)))) 2047 (concat
2045 (format "digest (%d message%s)" n (if (= n 1) "" "s")))) 2048 (if description description "")
2046 ((vm-mime-types-match "multipart/alternative" type) 2049 (if description ", " "")
2047 "multipart alternative") 2050 (cond ((vm-mime-types-match "multipart/digest" type)
2048 ((vm-mime-types-match "multipart" type) 2051 (let ((n (length (vm-mm-layout-parts layout))))
2049 (let ((n (length (vm-mm-layout-parts layout)))) 2052 (format "digest (%d message%s)" n (if (= n 1) "" "s"))))
2050 (format "multipart message (%d part%s)" n (if (= n 1) "" "s")))) 2053 ((vm-mime-types-match "multipart/alternative" type)
2051 ((vm-mime-types-match "text/plain" type) 2054 "multipart alternative")
2052 (format "plain text%s" 2055 ((vm-mime-types-match "multipart" type)
2053 (let ((charset (vm-mime-get-parameter layout "charset"))) 2056 (let ((n (length (vm-mm-layout-parts layout))))
2054 (if charset 2057 (format "multipart message (%d part%s)" n (if (= n 1) "" "s"))))
2055 (concat ", " charset) 2058 ((vm-mime-types-match "text/plain" type)
2056 "")))) 2059 (format "plain text%s"
2057 ((vm-mime-types-match "text/enriched" type) 2060 (let ((charset (vm-mime-get-parameter layout "charset")))
2058 "enriched text") 2061 (if charset
2059 ((vm-mime-types-match "text/html" type) 2062 (concat ", " charset)
2060 "HTML") 2063 ""))))
2061 ((vm-mime-types-match "image/gif" type) 2064 ((vm-mime-types-match "text/enriched" type)
2062 "GIF image") 2065 "enriched text")
2063 ((vm-mime-types-match "image/jpeg" type) 2066 ((vm-mime-types-match "text/html" type)
2064 "JPEG image") 2067 "HTML")
2065 ((and (vm-mime-types-match "application/octet-stream" type) 2068 ((vm-mime-types-match "image/gif" type)
2066 (setq name (vm-mime-get-parameter layout "name")) 2069 "GIF image")
2067 (save-match-data (not (string-match "^[ \t]*$" name)))) 2070 ((vm-mime-types-match "image/jpeg" type)
2068 name) 2071 "JPEG image")
2069 (t type))))) 2072 ((and (vm-mime-types-match "application/octet-stream" type)
2073 (setq name (vm-mime-get-parameter layout "name"))
2074 (save-match-data (not (string-match "^[ \t]*$" name))))
2075 name)
2076 (t type)))))
2070 2077
2071 (defun vm-mime-layout-contains-type (layout type) 2078 (defun vm-mime-layout-contains-type (layout type)
2072 (if (vm-mime-types-match type (car (vm-mm-layout-type layout))) 2079 (if (vm-mime-types-match type (car (vm-mm-layout-type layout)))
2073 layout 2080 layout
2074 (let ((p (vm-mm-layout-parts layout)) 2081 (let ((p (vm-mm-layout-parts layout))
2302 2309
2303 (defun vm-mime-fake-attachment-overlays (start end) 2310 (defun vm-mime-fake-attachment-overlays (start end)
2304 (let ((o-list nil) 2311 (let ((o-list nil)
2305 (done nil) 2312 (done nil)
2306 (pos start) 2313 (pos start)
2307 object pos props o) 2314 object props o)
2308 (save-excursion 2315 (save-excursion
2309 (save-restriction 2316 (save-restriction
2310 (narrow-to-region start end) 2317 (narrow-to-region start end)
2311 (while (not done) 2318 (while (not done)
2312 (setq object (get-text-property pos 'vm-mime-object)) 2319 (setq object (get-text-property pos 'vm-mime-object))
2424 (if (null e-list) 2431 (if (null e-list)
2425 (progn 2432 (progn
2426 (narrow-to-region (point) (point-max)) 2433 (narrow-to-region (point) (point-max))
2427 (setq charset (vm-determine-proper-charset (point-min) 2434 (setq charset (vm-determine-proper-charset (point-min)
2428 (point-max))) 2435 (point-max)))
2429 (if (fboundp 'encode-coding-region) 2436 (if (vm-xemacs-mule-p)
2430 (encode-coding-region (point-min) (point-max) 2437 (encode-coding-region (point-min) (point-max)
2431 file-coding-system)) 2438 file-coding-system))
2432 (setq encoding (vm-determine-proper-content-transfer-encoding 2439 (setq encoding (vm-determine-proper-content-transfer-encoding
2433 (point-min) 2440 (point-min)
2434 (point-max)) 2441 (point-max))
2594 ;; extent, if any. 2601 ;; extent, if any.
2595 (if (or just-one (= (point) (point-max))) 2602 (if (or just-one (= (point) (point-max)))
2596 nil 2603 nil
2597 (setq charset (vm-determine-proper-charset (point) 2604 (setq charset (vm-determine-proper-charset (point)
2598 (point-max))) 2605 (point-max)))
2599 (if (fboundp 'encode-coding-region) 2606 (if (vm-xemacs-mule-p)
2600 (encode-coding-region (point-min) (point-max) 2607 (encode-coding-region (point-min) (point-max)
2601 file-coding-system)) 2608 file-coding-system))
2602 (setq encoding (vm-determine-proper-content-transfer-encoding 2609 (setq encoding (vm-determine-proper-content-transfer-encoding
2603 (point) 2610 (point)
2604 (point-max)) 2611 (point-max))
2676 (insert "Content-Transfer-Encoding: 7bit\n"))))))) 2683 (insert "Content-Transfer-Encoding: 7bit\n")))))))
2677 2684
2678 (defun vm-mime-fragment-composition (size) 2685 (defun vm-mime-fragment-composition (size)
2679 (save-restriction 2686 (save-restriction
2680 (widen) 2687 (widen)
2681 (vm-unsaved-message "Fragmenting message...") 2688 (message "Fragmenting message...")
2682 (let ((buffers nil) 2689 (let ((buffers nil)
2683 (id (vm-mime-make-multipart-boundary)) 2690 (id (vm-mime-make-multipart-boundary))
2684 (n 1) 2691 (n 1)
2685 (the-end nil) 2692 (the-end nil)
2686 b header-start header-end master-buffer start end) 2693 b header-start header-end master-buffer start end)
2736 (insert mail-header-separator "\n") 2743 (insert mail-header-separator "\n")
2737 (insert-buffer-substring master-buffer start end) 2744 (insert-buffer-substring master-buffer start end)
2738 (vm-increment n) 2745 (vm-increment n)
2739 (set-buffer master-buffer) 2746 (set-buffer master-buffer)
2740 (setq start (point))) 2747 (setq start (point)))
2741 (vm-unsaved-message "Fragmenting message... done") 2748 (message "Fragmenting message... done")
2742 (nreverse buffers)))) 2749 (nreverse buffers))))
2743 2750
2744 (defun vm-mime-preview-composition () 2751 (defun vm-mime-preview-composition ()
2745 "Show how the current composition buffer might be displayed 2752 "Show how the current composition buffer might be displayed
2746 in a MIME-aware mail reader. VM copies and encodes the current 2753 in a MIME-aware mail reader. VM copies and encodes the current
2753 (let ((temp-buffer nil) 2760 (let ((temp-buffer nil)
2754 (mail-buffer (current-buffer)) 2761 (mail-buffer (current-buffer))
2755 e-list) 2762 e-list)
2756 (unwind-protect 2763 (unwind-protect
2757 (progn 2764 (progn
2758 (mail-text)
2759 (setq e-list (if (fboundp 'extent-list)
2760 (extent-list nil (point) (point-max))
2761 (overlays-in (point) (point-max)))
2762 e-list (vm-delete (function
2763 (lambda (e)
2764 (vm-extent-property e 'vm-mime-object)))
2765 e-list t)
2766 e-list (sort e-list (function
2767 (lambda (e1 e2)
2768 (< (vm-extent-end-position e1)
2769 (vm-extent-end-position e2))))))
2770 (setq temp-buffer (generate-new-buffer "composition preview")) 2765 (setq temp-buffer (generate-new-buffer "composition preview"))
2771 (set-buffer temp-buffer) 2766 (set-buffer temp-buffer)
2772 ;; so vm-mime-encode-composition won't complain 2767 ;; so vm-mime-encode-composition won't complain
2773 (setq major-mode 'mail-mode) 2768 (setq major-mode 'mail-mode)
2774 (vm-insert-region-from-buffer mail-buffer) 2769 (vm-insert-region-from-buffer mail-buffer)
2775 (if (vm-fsfemacs-19-p)
2776 (mapcar 'vm-copy-extent e-list))
2777 (goto-char (point-min)) 2770 (goto-char (point-min))
2778 (or (vm-mail-mode-get-header-contents "From") 2771 (or (vm-mail-mode-get-header-contents "From")
2779 (insert "From: " (or user-mail-address (user-login-name)) "\n")) 2772 (insert "From: " (or user-mail-address (user-login-name)) "\n"))
2780 (or (vm-mail-mode-get-header-contents "Message-ID") 2773 (or (vm-mail-mode-get-header-contents "Message-ID")
2781 (insert "Message-ID: <fake@fake.fake>\n")) 2774 (insert "Message-ID: <fake@fake.fake>\n"))