1 |
;;; mh-mime.el --- MH-E support for composing MIME messages |
;;; mh-mime.el --- MH-E support for composing MIME messages |
2 |
|
|
3 |
;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc. |
;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004 Free Software Foundation, Inc. |
4 |
|
|
5 |
;; Author: Bill Wohler <wohler@newt.com> |
;; Author: Bill Wohler <wohler@newt.com> |
6 |
;; Maintainer: Bill Wohler <wohler@newt.com> |
;; Maintainer: Bill Wohler <wohler@newt.com> |
34 |
|
|
35 |
;;; Code: |
;;; Code: |
36 |
|
|
|
(require 'cl) |
|
|
(require 'mh-comp) |
|
37 |
(require 'mh-utils) |
(require 'mh-utils) |
38 |
(load "mm-decode" t t) ; Non-fatal dependency |
(mh-require-cl) |
39 |
(load "mm-uu" t t) ; Non-fatal dependency |
(require 'mh-comp) |
|
(load "mailcap" t t) ; Non-fatal dependency |
|
|
(load "smiley" t t) ; Non-fatal dependency |
|
40 |
(require 'gnus-util) |
(require 'gnus-util) |
41 |
|
(require 'mh-gnus) |
42 |
|
|
43 |
(autoload 'gnus-article-goto-header "gnus-art") |
(autoload 'gnus-article-goto-header "gnus-art") |
44 |
(autoload 'article-emphasize "gnus-art") |
(autoload 'article-emphasize "gnus-art") |
447 |
This step is performed automatically when sending the message, but this |
This step is performed automatically when sending the message, but this |
448 |
function may be called manually before sending the draft as well." |
function may be called manually before sending the draft as well." |
449 |
(interactive) |
(interactive) |
450 |
|
(require 'message) |
451 |
(when mh-gnus-pgp-support-flag ;; This is only needed for PGP |
(when mh-gnus-pgp-support-flag ;; This is only needed for PGP |
452 |
(message-options-set-recipient)) |
(message-options-set-recipient)) |
453 |
(mml-to-mime)) |
(mml-to-mime)) |
527 |
|
|
528 |
|
|
529 |
|
|
|
;;; MIME decoding |
|
|
|
|
|
(defmacro mh-defun-compat (function arg-list &rest body) |
|
|
"This is a macro to define functions which are not defined. |
|
|
It is used for Gnus utility functions which were added recently. If FUNCTION |
|
|
is not defined then it is defined to have argument list, ARG-LIST and body, |
|
|
BODY." |
|
|
(let ((defined-p (fboundp function))) |
|
|
(unless defined-p |
|
|
`(defun ,function ,arg-list ,@body)))) |
|
|
(put 'mh-defun-compat 'lisp-indent-function 'defun) |
|
|
|
|
|
;; Copy of original function from gnus-util.el |
|
|
(mh-defun-compat gnus-local-map-property (map) |
|
|
"Return a list suitable for a text property list specifying keymap MAP." |
|
|
(cond (mh-xemacs-flag (list 'keymap map)) |
|
|
((>= emacs-major-version 21) (list 'keymap map)) |
|
|
(t (list 'local-map map)))) |
|
|
|
|
|
;; Copy of original function from mm-decode.el |
|
|
(mh-defun-compat mm-merge-handles (handles1 handles2) |
|
|
(append (if (listp (car handles1)) handles1 (list handles1)) |
|
|
(if (listp (car handles2)) handles2 (list handles2)))) |
|
|
|
|
|
;; Copy of function from mm-decode.el |
|
|
(mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value) |
|
|
;; HANDLE could be a CTL. |
|
|
(if handle |
|
|
(put-text-property 0 (length (car handle)) parameter value |
|
|
(car handle)))) |
|
|
|
|
|
;; Copy of original macro is in mm-decode.el |
|
|
(mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter) |
|
|
(get-text-property 0 parameter (car handle))) |
|
|
|
|
|
(mh-do-in-xemacs (defvar default-enable-multibyte-characters)) |
|
|
|
|
|
;; Copy of original function in mm-decode.el |
|
|
(mh-defun-compat mm-readable-p (handle) |
|
|
"Say whether the content of HANDLE is readable." |
|
|
(and (< (with-current-buffer (mm-handle-buffer handle) |
|
|
(buffer-size)) 10000) |
|
|
(mm-with-unibyte-buffer |
|
|
(mm-insert-part handle) |
|
|
(and (eq (mm-body-7-or-8) '7bit) |
|
|
(not (mm-long-lines-p 76)))))) |
|
|
|
|
|
;; Copy of original function in mm-bodies.el |
|
|
(mh-defun-compat mm-long-lines-p (length) |
|
|
"Say whether any of the lines in the buffer is longer than LINES." |
|
|
(save-excursion |
|
|
(goto-char (point-min)) |
|
|
(end-of-line) |
|
|
(while (and (not (eobp)) |
|
|
(not (> (current-column) length))) |
|
|
(forward-line 1) |
|
|
(end-of-line)) |
|
|
(and (> (current-column) length) |
|
|
(current-column)))) |
|
|
|
|
|
(mh-defun-compat mm-keep-viewer-alive-p (handle) |
|
|
;; Released Gnus doesn't keep handles associated with externally displayed |
|
|
;; MIME parts. So this will always return nil. |
|
|
nil) |
|
|
|
|
|
(mh-defun-compat mm-destroy-parts (list) |
|
|
"Older emacs don't have this function." |
|
|
nil) |
|
|
|
|
|
;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is |
|
|
;;; buggy (the args to read-file-name are incorrect). When all supported |
|
|
;;; versions of Emacs come with at least Gnus 5.10, we can delete this |
|
|
;;; function and rename calls to mh-mm-save-part to mm-save-part. |
|
|
(defun mh-mm-save-part (handle) |
|
|
"Write HANDLE to a file." |
|
|
(let ((name (mail-content-type-get (mm-handle-type handle) 'name)) |
|
|
(filename (mail-content-type-get |
|
|
(mm-handle-disposition handle) 'filename)) |
|
|
file) |
|
|
(when filename |
|
|
(setq filename (file-name-nondirectory filename))) |
|
|
(setq file (read-file-name "Save MIME part to: " |
|
|
(or mm-default-directory |
|
|
default-directory) |
|
|
nil nil (or filename name ""))) |
|
|
(setq mm-default-directory (file-name-directory file)) |
|
|
(and (or (not (file-exists-p file)) |
|
|
(yes-or-no-p (format "File %s already exists; overwrite? " |
|
|
file))) |
|
|
(mm-save-part-to-file handle file)))) |
|
|
|
|
|
|
|
|
|
|
530 |
;;; MIME cleanup |
;;; MIME cleanup |
531 |
|
|
532 |
;;;###mh-autoload |
;;;###mh-autoload |
573 |
I have seen this only in spam, so maybe we shouldn't fix this ;-)" |
I have seen this only in spam, so maybe we shouldn't fix this ;-)" |
574 |
(save-excursion |
(save-excursion |
575 |
(goto-char (point-min)) |
(goto-char (point-min)) |
576 |
(when (and (message-fetch-field "content-type") |
(re-search-forward "\n\n" nil t) |
577 |
(not (message-fetch-field "mime-version"))) |
(save-restriction |
578 |
(when (search-forward "\n\n" nil t) |
(narrow-to-region (point-min) (point)) |
579 |
(forward-line -1) |
(when (and (message-fetch-field "content-type") |
580 |
|
(not (message-fetch-field "mime-version"))) |
581 |
|
(goto-char (point-min)) |
582 |
(insert "MIME-Version: 1.0\n"))))) |
(insert "MIME-Version: 1.0\n"))))) |
583 |
|
|
584 |
|
(defun mh-small-show-buffer-p () |
585 |
|
"Check if show buffer is small. |
586 |
|
This is used to decide if smileys and graphical emphasis will be displayed." |
587 |
|
(let ((max nil)) |
588 |
|
(when (and (boundp 'font-lock-maximum-size) font-lock-maximum-size) |
589 |
|
(cond ((numberp font-lock-maximum-size) |
590 |
|
(setq max font-lock-maximum-size)) |
591 |
|
((listp font-lock-maximum-size) |
592 |
|
(setq max (cdr (or (assoc 'mh-show-mode font-lock-maximum-size) |
593 |
|
(assoc t font-lock-maximum-size))))))) |
594 |
|
(or (not (numberp max)) (>= (/ max 8) (buffer-size))))) |
595 |
|
|
596 |
;;;###mh-autoload |
;;;###mh-autoload |
597 |
(defun mh-display-smileys () |
(defun mh-display-smileys () |
598 |
"Function to display smileys." |
"Function to display smileys." |
599 |
(when (and mh-graphical-smileys-flag |
(when (and mh-graphical-smileys-flag (mh-small-show-buffer-p)) |
600 |
(fboundp 'smiley-region) |
(mh-funcall-if-exists smiley-region (point-min) (point-max)))) |
|
(boundp 'font-lock-maximum-size) |
|
|
font-lock-maximum-size |
|
|
(>= (/ font-lock-maximum-size 8) (buffer-size))) |
|
|
(smiley-region (point-min) (point-max)))) |
|
601 |
|
|
602 |
;;;###mh-autoload |
;;;###mh-autoload |
603 |
(defun mh-display-emphasis () |
(defun mh-display-emphasis () |
604 |
"Function to display graphical emphasis." |
"Function to display graphical emphasis." |
605 |
(when (and mh-graphical-emphasis-flag |
(when (and mh-graphical-emphasis-flag (mh-small-show-buffer-p)) |
|
(if font-lock-maximum-size |
|
|
(>= (/ font-lock-maximum-size 8) (buffer-size)))) |
|
606 |
(flet ((article-goto-body ())) ; shadow this function to do nothing |
(flet ((article-goto-body ())) ; shadow this function to do nothing |
607 |
(save-excursion |
(save-excursion |
608 |
(goto-char (point-min)) |
(goto-char (point-min)) |
712 |
(defun mh-decode-message-body () |
(defun mh-decode-message-body () |
713 |
"Decode message based on charset. |
"Decode message based on charset. |
714 |
If message has been encoded for transfer take that into account." |
If message has been encoded for transfer take that into account." |
715 |
(let* ((ct (ignore-errors (mail-header-parse-content-type |
(let (ct charset cte) |
716 |
(message-fetch-field "Content-Type" t)))) |
(goto-char (point-min)) |
717 |
(charset (mail-content-type-get ct 'charset)) |
(re-search-forward "\n\n" nil t) |
718 |
(cte (message-fetch-field "Content-Transfer-Encoding"))) |
(save-restriction |
719 |
|
(narrow-to-region (point-min) (point)) |
720 |
|
(setq ct (ignore-errors (mail-header-parse-content-type |
721 |
|
(message-fetch-field "Content-Type" t))) |
722 |
|
charset (mail-content-type-get ct 'charset) |
723 |
|
cte (message-fetch-field "Content-Transfer-Encoding"))) |
724 |
(when (stringp cte) (setq cte (mail-header-strip cte))) |
(when (stringp cte) (setq cte (mail-header-strip cte))) |
725 |
(when (or (not ct) (equal (car ct) "text/plain")) |
(when (or (not ct) (equal (car ct) "text/plain")) |
726 |
(save-restriction |
(save-restriction |
799 |
(defun mh-mime-display-alternative (handles) |
(defun mh-mime-display-alternative (handles) |
800 |
"Choose among the alternatives, HANDLES the part that will be displayed. |
"Choose among the alternatives, HANDLES the part that will be displayed. |
801 |
If no part is preferred then all the parts are displayed." |
If no part is preferred then all the parts are displayed." |
802 |
(let ((preferred (mm-preferred-alternative handles))) |
(let* ((preferred (mm-preferred-alternative handles)) |
803 |
|
(others (loop for x in handles unless (eq x preferred) collect x))) |
804 |
(cond ((and preferred (stringp (car preferred))) |
(cond ((and preferred (stringp (car preferred))) |
805 |
(mh-mime-display-part preferred)) |
(mh-mime-display-part preferred) |
806 |
|
(mh-mime-maybe-display-alternatives others)) |
807 |
(preferred |
(preferred |
808 |
(save-restriction |
(save-restriction |
809 |
(narrow-to-region (point) (if (eobp) (point) (1+ (point)))) |
(narrow-to-region (point) (if (eobp) (point) (1+ (point)))) |
810 |
(mh-mime-display-single preferred) |
(mh-mime-display-single preferred) |
811 |
|
(mh-mime-maybe-display-alternatives others) |
812 |
(goto-char (point-max)))) |
(goto-char (point-max)))) |
813 |
(t (mh-mime-display-mixed handles))))) |
(t (mh-mime-display-mixed handles))))) |
814 |
|
|
815 |
|
(defun mh-mime-maybe-display-alternatives (alternatives) |
816 |
|
"Show buttons for ALTERNATIVES. |
817 |
|
If `mh-mime-display-alternatives-flag' is non-nil then display buttons for |
818 |
|
alternative parts that are usually suppressed." |
819 |
|
(when (and mh-display-buttons-for-alternatives-flag alternatives) |
820 |
|
(insert "\n----------------------------------------------------\n") |
821 |
|
(insert "Alternatives:\n") |
822 |
|
(dolist (x alternatives) |
823 |
|
(insert "\n") |
824 |
|
(mh-insert-mime-button x (mh-mime-part-index x) nil)) |
825 |
|
(insert "\n----------------------------------------------------\n"))) |
826 |
|
|
827 |
(defun mh-mime-display-mixed (handles) |
(defun mh-mime-display-mixed (handles) |
828 |
"Display the list of MIME parts, HANDLES recursively." |
"Display the list of MIME parts, HANDLES recursively." |
829 |
(mapcar #'mh-mime-display-part handles)) |
(mapcar #'mh-mime-display-part handles)) |
837 |
(setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) |
(setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) |
838 |
(incf (mh-mime-parts-count (mh-buffer-data)))))) |
(incf (mh-mime-parts-count (mh-buffer-data)))))) |
839 |
|
|
|
;;; Avoid compiler warnings for XEmacs functions... |
|
|
(eval-when (compile) |
|
|
(loop for function in '(glyph-width window-pixel-width |
|
|
glyph-height window-pixel-height) |
|
|
do (or (fboundp function) (defalias function 'ignore)))) |
|
|
|
|
840 |
(defun mh-small-image-p (handle) |
(defun mh-small-image-p (handle) |
841 |
"Decide whether HANDLE is a \"small\" image that can be displayed inline. |
"Decide whether HANDLE is a \"small\" image that can be displayed inline. |
842 |
This is only useful if a Content-Disposition header is not present." |
This is only useful if a Content-Disposition header is not present." |
849 |
; this only tells us if the image is |
; this only tells us if the image is |
850 |
; something that emacs can display |
; something that emacs can display |
851 |
(let* ((image (mm-get-image handle))) |
(let* ((image (mm-get-image handle))) |
852 |
(cond ((fboundp 'glyph-width) |
(or (mh-do-in-xemacs |
853 |
;; XEmacs -- totally untested, copied from gnus |
(and (mh-funcall-if-exists glyphp image) |
854 |
(and (mh-funcall-if-exists glyphp image) |
(< (glyph-width image) |
855 |
(< (glyph-width image) |
(or mh-max-inline-image-width (window-pixel-width))) |
856 |
(or mh-max-inline-image-width |
(< (glyph-height image) |
857 |
(window-pixel-width))) |
(or mh-max-inline-image-height |
858 |
(< (glyph-height image) |
(window-pixel-height))))) |
859 |
(or mh-max-inline-image-height |
(mh-do-in-gnu-emacs |
860 |
(window-pixel-height))))) |
(let ((size (mh-funcall-if-exists image-size image))) |
861 |
((fboundp 'image-size) |
(and size |
862 |
;; Emacs21 -- copied from gnus |
(< (cdr size) (or mh-max-inline-image-height |
863 |
(let ((size (mh-funcall-if-exists image-size image))) |
(1- (window-height)))) |
864 |
(and size |
(< (car size) (or mh-max-inline-image-width |
865 |
(< (cdr size) |
(window-width))))))))))) |
|
(or mh-max-inline-image-height |
|
|
(1- (window-height)))) |
|
|
(< (car size) |
|
|
(or mh-max-inline-image-width (window-width)))))) |
|
|
(t |
|
|
;; Can't show image inline |
|
|
nil)))))) |
|
866 |
|
|
867 |
(defun mh-inline-vcard-p (handle) |
(defun mh-inline-vcard-p (handle) |
868 |
"Decide if HANDLE is a vcard that must be displayed inline." |
"Decide if HANDLE is a vcard that must be displayed inline." |
982 |
(progn |
(progn |
983 |
;; Delete the button and displayed part (if any) |
;; Delete the button and displayed part (if any) |
984 |
(let ((region (get-text-property point 'mh-region))) |
(let ((region (get-text-property point 'mh-region))) |
985 |
(when (and region (fboundp 'remove-images)) |
(when region |
986 |
(mh-funcall-if-exists |
(mh-funcall-if-exists |
987 |
remove-images (car region) (cdr region))) |
remove-images (car region) (cdr region))) |
988 |
(mm-display-part handle) |
(mm-display-part handle) |
1050 |
displayed. This function is called when the mouse is used to click the MIME |
displayed. This function is called when the mouse is used to click the MIME |
1051 |
button." |
button." |
1052 |
(interactive "e") |
(interactive "e") |
1053 |
(save-excursion |
(mh-do-at-event-location event |
1054 |
(let* ((event-window |
(let ((folder mh-show-folder-buffer) |
1055 |
(or (mh-funcall-if-exists posn-window (event-start event));GNU Emacs |
(mm-inline-media-tests mh-mm-inline-media-tests) |
1056 |
(mh-funcall-if-exists event-window event))) ;XEmacs |
(data (get-text-property (point) 'mh-data)) |
1057 |
(event-position |
(function (get-text-property (point) 'mh-callback))) |
1058 |
(or (mh-funcall-if-exists posn-point (event-start event)) ;GNU Emacs |
(flet ((mm-handle-set-external-undisplayer (handle func) |
1059 |
(mh-funcall-if-exists event-closest-point event))) ;XEmacs |
(mh-handle-set-external-undisplayer folder handle func))) |
1060 |
(original-window (selected-window)) |
(and function (funcall function data)))))) |
|
(original-position (progn |
|
|
(set-buffer (window-buffer event-window)) |
|
|
(set-marker (make-marker) (point)))) |
|
|
(folder mh-show-folder-buffer) |
|
|
(mm-inline-media-tests mh-mm-inline-media-tests) |
|
|
(data (get-text-property event-position 'mh-data)) |
|
|
(function (get-text-property event-position 'mh-callback)) |
|
|
(buffer-read-only nil)) |
|
|
(unwind-protect |
|
|
(progn |
|
|
(select-window event-window) |
|
|
(flet ((mm-handle-set-external-undisplayer (handle func) |
|
|
(mh-handle-set-external-undisplayer folder handle func))) |
|
|
(goto-char event-position) |
|
|
(and function (funcall function data)))) |
|
|
(set-buffer-modified-p nil) |
|
|
(goto-char original-position) |
|
|
(set-marker original-position nil) |
|
|
(select-window original-window))))) |
|
1061 |
|
|
1062 |
;;;###mh-autoload |
;;;###mh-autoload |
1063 |
(defun mh-mime-save-part () |
(defun mh-mime-save-part () |
1065 |
(interactive) |
(interactive) |
1066 |
(let ((data (get-text-property (point) 'mh-data))) |
(let ((data (get-text-property (point) 'mh-data))) |
1067 |
(when data |
(when data |
1068 |
(let ((mm-default-directory mh-mime-save-parts-directory)) |
(let ((mm-default-directory |
1069 |
|
(file-name-as-directory (or mh-mime-save-parts-directory |
1070 |
|
default-directory)))) |
1071 |
(mh-mm-save-part data) |
(mh-mm-save-part data) |
1072 |
(setq mh-mime-save-parts-directory mm-default-directory))))) |
(setq mh-mime-save-parts-directory mm-default-directory))))) |
1073 |
|
|