;;; Commentary:
-;; Jaap-Henk Hoepman (jhh@xs4all.nl):
+;; Jaap-Henk Hoepman (jhh@xs4all.nl):
;;
;; Added support for delayed destroy of external MIME viewers. All external
;; viewers for mime types in mm-keep-viewer-alive-types will remain active
;; after switching articles or groups, and will only be removed when exiting
;; gnus.
-;;
+;;
;;; Code:
(require 'mail-parse)
(require 'gnus-mailcap)
(require 'mm-bodies)
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl)
+ (require 'term))
(eval-and-compile
(autoload 'mm-inline-partial "mm-partial")
("application/pgp-signature" ignore identity)
("application/x-pkcs7-signature" ignore identity)
("application/pkcs7-signature" ignore identity)
+ ("application/x-pkcs7-mime" ignore identity)
+ ("application/pkcs7-mime" ignore identity)
("multipart/alternative" ignore identity)
("multipart/mixed" ignore identity)
- ("multipart/related" ignore identity))
+ ("multipart/related" ignore identity)
+ ;; Disable audio and image
+ ("audio/.*" ignore ignore)
+ ("image/.*" ignore ignore)
+ ;; Default to displaying as text
+ (".*" mm-inline-text mm-readable-p))
"Alist of media types/tests saying whether types can be displayed inline."
:type '(repeat (list (string :tag "MIME type")
(function :tag "Display function")
'("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
"message/partial" "message/external-body" "application/emacs-lisp"
"application/pgp-signature" "application/x-pkcs7-signature"
- "application/pkcs7-signature")
+ "application/pkcs7-signature" "application/x-pkcs7-mime"
+ "application/pkcs7-mime")
"List of media types that are to be displayed inline.
See also `mm-inline-media-tests', which says how to display a media
-type inline. If no media test is defined, the default is to treat the
-type as plain text."
+type inline."
:type '(repeat string)
:group 'mime-display)
when selecting a different article."
:type '(repeat string)
:group 'mime-display)
-
+
(defcustom mm-automatic-display
'("text/plain" "text/enriched" "text/richtext" "text/html"
"text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
"message/rfc822" "text/x-patch" "application/pgp-signature"
"application/emacs-lisp" "application/x-pkcs7-signature"
- "application/pkcs7-signature")
+ "application/pkcs7-signature" "application/x-pkcs7-mime"
+ "application/pkcs7-mime")
"A list of MIME types to be displayed automatically."
:type '(repeat string)
:group 'mime-display)
-(defcustom mm-attachment-override-types '("text/x-vcard")
+(defcustom mm-attachment-override-types '("text/x-vcard"
+ "application/pkcs7-mime"
+ "application/x-pkcs7-mime")
"Types to have \"attachment\" ignored if they can be displayed inline."
:type '(repeat string)
:group 'mime-display)
:type 'directory
:group 'mime-display)
+(defcustom mm-external-terminal-program "xterm"
+ "The program to start an external terminal."
+ :type 'string
+ :group 'mime-display)
+
;;; Internal variables.
(defvar mm-dissection-list nil)
(throw 'found t))))))
(defun mm-handle-set-external-undisplayer (handle function)
- "Set the undisplayer for this handle; postpone undisplaying of viewers
+ "Set the undisplayer for this handle; postpone undisplaying of viewers
for types in mm-keep-viewer-alive-types."
- (if (mm-keep-viewer-alive-p handle)
- (let ((new-handle (copy-sequence handle)))
- (mm-handle-set-undisplayer new-handle function)
- (mm-handle-set-undisplayer handle nil)
- (push new-handle mm-postponed-undisplay-list))
- (mm-handle-set-undisplayer handle function)))
+ (if (mm-keep-viewer-alive-p handle)
+ (let ((new-handle (copy-sequence handle)))
+ (mm-handle-set-undisplayer new-handle function)
+ (mm-handle-set-undisplayer handle nil)
+ (push new-handle mm-postponed-undisplay-list))
+ (mm-handle-set-undisplayer handle function)))
(defun mm-destroy-postponed-undisplay-list ()
(message "Destroying external MIME viewers")
(let ((mm-dissect-default-type (if (equal subtype "digest")
"message/rfc822"
"text/plain")))
- (add-text-properties 0 (length (car ctl))
- (mm-alist-to-plist (cdr ctl)) (car ctl))
+ (add-text-properties 0 (length (car ctl))
+ (mm-alist-to-plist (cdr ctl)) (car ctl))
;; what really needs to be done here is a way to link a
;; MIME handle back to it's parent MIME handle (in a multilevel
;; MIME article). That would probably require changing
;; the mm-handle API so we simply store the multipart buffert
;; name as a text property of the "multipart/whatever" string.
- (add-text-properties 0 (length (car ctl))
+ (add-text-properties 0 (length (car ctl))
(list 'buffer (mm-copy-to-buffer))
- (car ctl))
- (add-text-properties 0 (length (car ctl))
+ (car ctl))
+ (add-text-properties 0 (length (car ctl))
(list 'from from)
- (car ctl))
+ (car ctl))
(cons (car ctl) (mm-dissect-multipart ctl))))
(t
- (mm-dissect-singlepart
- ctl
- (and cte (intern (downcase (mail-header-remove-whitespace
- (mail-header-remove-comments
- cte)))))
- no-strict-mime
- (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
- description id))))
+ (mm-possibly-verify-or-decrypt
+ (mm-dissect-singlepart
+ ctl
+ (and cte (intern (downcase (mail-header-remove-whitespace
+ (mail-header-remove-comments
+ cte)))))
+ no-strict-mime
+ (and cd (ignore-errors
+ (mail-header-parse-content-disposition cd)))
+ description id)
+ ctl))))
(when id
(when (string-match " *<\\(.*\\)> *" id)
(setq id (match-string 1 id)))
(mm-remove-part handle)
(let* ((type (mm-handle-media-type handle))
(method (mailcap-mime-info type)))
- (if (mm-inlined-p handle)
+ (if (and (mm-inlinable-p handle)
+ (mm-inlined-p handle))
(progn
(forward-line 1)
(mm-display-inline handle)
(message "Viewing with %s" method)
(cond (needsterm
(unwind-protect
- (start-process "*display*" nil
- "xterm"
- "-e" shell-file-name
- shell-command-switch
- (mm-mailcap-command
- method file (mm-handle-type handle)))
+ (if window-system
+ (start-process "*display*" nil
+ mm-external-terminal-program
+ "-e" shell-file-name
+ shell-command-switch
+ (mm-mailcap-command
+ method file (mm-handle-type handle)))
+ (require 'term)
+ (require 'gnus-win)
+ (set-buffer
+ (setq buffer
+ (make-term "display"
+ shell-file-name
+ nil
+ shell-command-switch
+ (mm-mailcap-command
+ method file
+ (mm-handle-type handle)))))
+ (term-mode)
+ (term-char-mode)
+ (set-process-sentinel
+ (get-buffer-process buffer)
+ `(lambda (process state)
+ (if (eq 'exit (process-status process))
+ (gnus-configure-windows
+ ',gnus-current-window-configuration))))
+ (gnus-configure-windows 'display-term))
(mm-handle-set-external-undisplayer handle (cons file buffer)))
(message "Displaying %s..." (format method file))
'external)
((consp object)
(ignore-errors (delete-file (car object)))
(ignore-errors (delete-directory (file-name-directory (car object))))
- (ignore-errors (kill-buffer (cdr object))))
+ (ignore-errors (and (cdr object) (kill-buffer (cdr object)))))
((bufferp object)
(when (buffer-live-p object)
(kill-buffer object)))))
(defun mm-display-inline (handle)
(let* ((type (mm-handle-media-type handle))
(function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
- (funcall (or function #'mm-inline-text) handle)
+ (funcall function handle)
(goto-char (point-min))))
(defun mm-assoc-string-match (alist type)
methods nil)))
result))
+(defun mm-inlinable-p (handle)
+ "Say whether HANDLE can be displayed inline."
+ (let ((alist mm-inline-media-tests)
+ (type (mm-handle-media-type handle))
+ test)
+ (while alist
+ (when (string-match (caar alist) type)
+ (setq test (caddar alist)
+ alist nil)
+ (setq test (funcall test handle)))
+ (pop alist))
+ test))
+
(defun mm-inlined-p (handle)
- "Say whether the user wants HANDLE to be displayed automatically."
+ "Say whether the user wants HANDLE to be displayed inline."
(let ((methods mm-inlined-types)
(type (mm-handle-media-type handle))
method result)
ty)
(catch 'found
(while (setq ty (pop types))
- (when (string-match ty type)
+ (when (and (string-match ty type)
+ (mm-inlinable-p handle))
(throw 'found t))))))
(defun mm-inline-override-p (handle)
(save-excursion
(if (member (mm-handle-media-supertype handle) '("text" "message"))
(with-temp-buffer
- (insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (mm-handle-media-type handle))
- (let ((temp (current-buffer)))
- (set-buffer cur)
- (insert-buffer-substring temp)))
+ (insert-buffer-substring (mm-handle-buffer handle))
+ (prog1
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ (let ((temp (current-buffer)))
+ (set-buffer cur)
+ (insert-buffer-substring temp))))
(mm-with-unibyte-buffer
(insert-buffer-substring (mm-handle-buffer handle))
- (mm-decode-content-transfer-encoding
- (mm-handle-encoding handle)
- (mm-handle-media-type handle))
- (let ((temp (current-buffer)))
- (set-buffer cur)
- (insert-buffer-substring temp)))))))
+ (prog1
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handle)
+ (mm-handle-media-type handle))
+ (let ((temp (current-buffer)))
+ (set-buffer cur)
+ (insert-buffer-substring temp))))))))
(defun mm-file-name-delete-whitespace (file-name)
"Remove all whitespace characters from FILE-NAME."
(defun mm-save-part-to-file (handle file)
(mm-with-unibyte-buffer
- (mm-insert-part handle)
+ (or (mm-insert-part handle)
+ (error "Error with message"))
(let ((coding-system-for-write 'binary)
;; Don't re-compress .gz & al. Arguably we should make
;; `file-name-handler-alist' nil, but that would chop
"Return the handle(s) referred to by ID."
(cdr (assoc id mm-content-id-alist)))
+(defconst mm-image-type-regexps
+ '(("/\\*.*XPM.\\*/" . xpm)
+ ("P[1-6]" . pbm)
+ ("GIF8" . gif)
+ ("\377\330" . jpeg)
+ ("\211PNG\r\n" . png)
+ ("#define" . xbm)
+ ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
+ ("%!PS" . postscript))
+ "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
+When the first bytes of an image file match REGEXP, it is assumed to
+be of image type IMAGE-TYPE.")
+
+;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
+(defun mm-image-type-from-buffer ()
+ "Determine the image type from data in the current buffer.
+Value is a symbol specifying the image type or nil if type cannot
+be determined."
+ (let ((types mm-image-type-regexps)
+ type)
+ (goto-char (point-min))
+ (while (and types (null type))
+ (let ((regexp (car (car types)))
+ (image-type (cdr (car types))))
+ (when (looking-at regexp)
+ (setq type image-type))
+ (setq types (cdr types))))
+ type))
+
(defun mm-get-image (handle)
"Return an image instance based on HANDLE."
(let ((type (mm-handle-media-subtype handle))
(prog1
(setq spec
(ignore-errors
- ;; Avoid testing `make-glyph' since W3 may define
- ;; a bogus version of it.
+ ;; Avoid testing `make-glyph' since W3 may define
+ ;; a bogus version of it.
(if (fboundp 'create-image)
- (create-image (buffer-string) (intern type) 'data-p)
+ (create-image (buffer-string)
+ (or (mm-image-type-from-buffer)
+ (intern type))
+ 'data-p)
(cond
((equal type "xbm")
;; xbm images require special handling, since
(write-region (point-min) (point-max) file)
(make-glyph (list (cons 'x file))))
(ignore-errors
- (delete-file file)))))
+ (delete-file file)))))
(t
(make-glyph
- (vector (intern type) :data (buffer-string))))))))
+ (vector
+ (or (mm-image-type-from-buffer)
+ (intern type))
+ :data (buffer-string))))))))
(mm-handle-set-cache handle spec))))))
(defun mm-image-fit-p (handle)
(car handle))))
(defun mm-possibly-verify-or-decrypt (parts ctl)
- (let ((subtype (cadr (split-string (car ctl) "/")))
+ (let ((type (car ctl))
+ (subtype (cadr (split-string (car ctl) "/")))
(mm-security-handle ctl) ;; (car CTL) is the type.
protocol func functest)
(cond
+ ((or (equal type "application/x-pkcs7-mime")
+ (equal type "application/pkcs7-mime"))
+ (with-temp-buffer
+ (when (and (cond
+ ((eq mm-decrypt-option 'never) nil)
+ ((eq mm-decrypt-option 'always) t)
+ ((eq mm-decrypt-option 'known) t)
+ (t (y-or-n-p
+ (format "Decrypt (S/MIME) part? "))))
+ (mm-view-pkcs7 parts))
+ (setq parts (mm-dissect-buffer t)))))
((equal subtype "signed")
(unless (and (setq protocol
(mm-handle-multipart-ctl-parameter ctl 'protocol))
parts))
(defun mm-multiple-handles (handles)
- (and (listp (car handles))
- (> (length handles) 1)))
+ (and (listp (car handles))
+ (> (length handles) 1)))
-(defun mm-merge-handles (handles1 handles2)
+(defun mm-merge-handles (handles1 handles2)
(append
- (if (listp (car handles1))
+ (if (listp (car handles1))
handles1
(list handles1))
(if (listp (car handles2))
handles2
(list handles2))))
+(defun 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))))))
+
(provide 'mm-decode)
;;; mm-decode.el ends here
projects / elisp / gnus.git- / blobdiff