/[emacs]/emacs/lisp/mh-e/mh-mime.el
ViewVC logotype

Diff of /emacs/lisp/mh-e/mh-mime.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.2 by miles, Tue Oct 14 23:39:26 2003 UTC revision 1.2.4.3 by miles, Sat Jul 17 02:51:49 2004 UTC
# Line 1  Line 1 
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>
# Line 34  Line 34 
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")
# Line 450  Optional non-nil argument NOCONFIRM mean Line 447  Optional non-nil argument NOCONFIRM mean
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))
# Line 529  If called with a prefix argument DONTSIG Line 527  If called with a prefix argument DONTSIG
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
# Line 668  undisplayer FUNCTION." Line 573  undisplayer FUNCTION."
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))
# Line 799  actual storing." Line 712  actual storing."
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
# Line 881  displayed." Line 799  displayed."
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))
# Line 904  opened)." Line 837  opened)."
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."
# Line 922  This is only useful if a Content-Disposi Line 849  This is only useful if a Content-Disposi
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."
# Line 1062  like \"K v\" which operate on individual Line 982  like \"K v\" which operate on individual
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)
# Line 1130  If the MIME part is visible then it is r Line 1050  If the MIME part is visible then it is r
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 ()
# Line 1164  button." Line 1065  button."
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    

Legend:
Removed from v.1.2.4.2  
changed lines
  Added in v.1.2.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26