;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(eval-when-compile (require 'cl))
(autoload 'gnus-map-function "gnus-util")
-(autoload 'gnus-replace-in-string "gnus-util")
-(autoload 'gnus-read-shell-command "gnus-util")
-
-(autoload 'gnus-overlays-at "gnus")
-(autoload 'gnus-overlay-put "gnus")
(autoload 'mm-inline-partial "mm-partial")
(autoload 'mm-inline-external-body "mm-extern")
(function))
:group 'mime-display)
-(defcustom mm-inline-text-html-with-images nil
- "If non-nil, Gnus will allow retrieving images in HTML that has <img> tags.
-See also the documentation for the `mm-w3m-safe-url-regexp'
-variable."
- :version "22.1"
+(defcustom mm-html-inhibit-images nil
+ "Non-nil means inhibit displaying of images inline in the article body."
+ :version "25.1"
:type 'boolean
:group 'mime-display)
+(defcustom mm-html-blocked-images ""
+ "Regexp matching image URLs to be blocked, or nil meaning not to block.
+Note that cid images that are embedded in a message won't be blocked."
+ :version "25.1"
+ :type '(choice (const :tag "Allow all" nil)
+ (regexp :tag "Regular expression"))
+ :group 'mime-display)
+
(defcustom mm-w3m-safe-url-regexp "\\`cid:"
"Regexp matching URLs which are considered to be safe.
Some HTML mails might contain a nasty trick used by spammers, using
(mm-insert-part handle)
(let ((image
(ignore-errors
- (if (fboundp 'create-image)
- (create-image (buffer-string) 'imagemagick 'data-p)
- (mm-create-image-xemacs
- (mm-handle-media-subtype handle))))))
+ (create-image (buffer-string) 'imagemagick 'data-p))))
(when image
(setcar (cdr handle) (list "image/imagemagick"))
(mm-image-fit-p handle)))))))
:type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
:group 'mime-display)
-(defcustom mm-tmp-directory
- (if (fboundp 'temp-directory)
- (temp-directory)
- (if (boundp 'temporary-file-directory)
- temporary-file-directory
- "/tmp/"))
+(defcustom mm-tmp-directory temporary-file-directory
"Where mm will store its temporary files."
:type 'directory
:group 'mime-display)
(defcustom mm-inline-large-images nil
"If t, then all images fit in the buffer.
-If 'resize, try to resize the images so they fit."
+If `resize', try to resize the images so they fit."
:type '(radio
(const :tag "Inline large images as they are." t)
(const :tag "Resize large images." resize)
\(a 1 b 2 c 3)
-The original alist is not modified. See also `destructive-alist-to-plist'."
+The original alist is not modified."
(let (plist)
(while alist
(let ((el (car alist)))
(with-current-buffer
(generate-new-buffer " *mm*")
;; Preserve the data's unibyteness (for url-insert-file-contents).
- (mm-set-buffer-multibyte mb)
+ (set-buffer-multibyte mb)
(insert-buffer-substring obuf beg)
(current-buffer))))
(concat
"using external program \""
(format method filename) "\"")
- (format
+ (format-message
"by calling `%s' on the contents)" method))
"? "))))))
(if external
(select-window win)))
(switch-to-buffer (generate-new-buffer " *mm*")))
(buffer-disable-undo)
- (mm-set-buffer-file-coding-system mm-binary-coding-system)
+ (set-buffer-file-coding-system mm-binary-coding-system)
(insert-buffer-substring cur)
(goto-char (point-min))
(when method
;; The function is a string to be executed.
(mm-insert-part handle)
(mm-add-meta-html-tag handle)
- (let* ((dir (mm-make-temp-file
+ (let* ((dir (make-temp-file
(expand-file-name "emm." mm-tmp-directory) 'dir))
(filename (or
(mail-content-type-get
;; `mailcap-mime-extensions'.
(setq suffix (car (rassoc (mm-handle-media-type handle)
mailcap-mime-extensions))))
- (setq file (mm-make-temp-file (expand-file-name "mm." dir)
- nil suffix))))
+ (setq file (make-temp-file (expand-file-name "mm." dir)
+ nil suffix))))
(let ((coding-system-for-write mm-binary-coding-system))
(write-region (point-min) (point-max) file nil 'nomesg))
;; The file is deleted after the viewer exists. If the users edits
(ignore-errors
(cond
;; Internally displayed part.
- ((mm-annotationp object)
- (if (featurep 'xemacs)
- (delete-annotation object)))
((or (functionp object)
(and (listp object)
(eq (car object) 'lambda)))
(with-current-buffer (mm-handle-buffer handle)
(buffer-string)))
((mm-multibyte-p)
- (mm-string-to-multibyte (mm-get-part handle no-cache)))
+ (string-to-multibyte (mm-get-part handle no-cache)))
(t
(mm-get-part handle no-cache)))))
(save-restriction
(defun mm-file-name-delete-control (filename)
"Delete control characters from FILENAME."
- (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
+ (replace-regexp-in-string "[\x00-\x1f\x7f]" "" filename))
(defun mm-file-name-delete-gotchas (filename)
"Delete shell gotchas from FILENAME."
- (setq filename (gnus-replace-in-string filename "[<>|]" ""))
- (gnus-replace-in-string filename "^[.-]+" ""))
+ (setq filename (replace-regexp-in-string "[<>|]" "" filename))
+ (replace-regexp-in-string "^[.-]+" "" filename))
(defun mm-save-part (handle &optional prompt)
"Write HANDLE to a file.
(goto-char (point-min))
(if (re-search-forward "\
<meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
-text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\([^\"'>]+\\)\\)?[^>]*>" nil t)
+text/\\(\\sw+\\)\\(?:;\\s-*charset=\\([^\"'>]+\\)\\)?[^>]*>" nil t)
(if (and (not force-charset)
(match-beginning 2)
(string-match "\\`html\\'" (match-string 1)))
Use CMD as the process."
(let ((name (mail-content-type-get (mm-handle-type handle) 'name))
(command (or cmd
- (gnus-read-shell-command
+ (read-shell-command
"Shell command on MIME part: " mm-last-shell-command))))
(mm-with-unibyte-buffer
(mm-insert-part handle)
(prog1
(setq spec
(ignore-errors
- ;; Avoid testing `make-glyph' since W3 may define
- ;; a bogus version of it.
- (if (fboundp 'create-image)
- (create-image (buffer-string)
- (or (mm-image-type-from-buffer)
- (intern type))
- 'data-p)
- (mm-create-image-xemacs type))))
+ (create-image (buffer-string)
+ (or (mm-image-type-from-buffer)
+ (intern type))
+ 'data-p)))
(mm-handle-set-cache handle spec))))))
-(defun mm-create-image-xemacs (type)
- (when (featurep 'xemacs)
- (cond
- ((equal type "xbm")
- ;; xbm images require special handling, since
- ;; the only way to create glyphs from these
- ;; (without a ton of work) is to write them
- ;; out to a file, and then create a file
- ;; specifier.
- (let ((file (mm-make-temp-file
- (expand-file-name "emm" mm-tmp-directory)
- nil ".xbm")))
- (unwind-protect
- (progn
- (write-region (point-min) (point-max) file)
- (make-glyph (list (cons 'x file))))
- (ignore-errors
- (delete-file file)))))
- (t
- (make-glyph
- (vector
- (or (mm-image-type-from-buffer)
- (intern type))
- :data (buffer-string)))))))
-
(declare-function image-size "image.c" (spec &optional pixels frame))
(defun mm-image-fit-p (handle)
"Say whether the image in HANDLE will fit the current window."
(let ((image (mm-get-image handle)))
(or (not image)
- (if (featurep 'xemacs)
- ;; XEmacs's glyphs can actually tell us about their width, so
- ;; let's be nice and smart about them.
- (or mm-inline-large-images
- (and (<= (glyph-width image) (window-pixel-width))
- (<= (glyph-height image) (window-pixel-height))))
- (let* ((size (image-size image))
- (w (car size))
- (h (cdr size)))
- (or mm-inline-large-images
- (and (<= h (1- (window-height))) ; Don't include mode line.
- (<= w (window-width)))))))))
+ (let* ((size (image-size image))
+ (w (car size))
+ (h (cdr size)))
+ (or mm-inline-large-images
+ (and (<= h (1- (window-height))) ; Don't include mode line.
+ (<= w (window-width))))))))
(defun mm-valid-image-format-p (format)
"Say whether FORMAT can be displayed natively by Emacs."
- (cond
- ;; Handle XEmacs
- ((fboundp 'valid-image-instantiator-format-p)
- (valid-image-instantiator-format-p format))
- ;; Handle Emacs
- ((fboundp 'image-type-available-p)
- (and (display-graphic-p)
- (image-type-available-p format)))
- ;; Nobody else can do images yet.
- (t
- nil)))
+ (and (display-graphic-p)
+ (image-type-available-p format)))
(defun mm-valid-and-fit-image-p (format handle)
"Say whether FORMAT can be displayed natively and HANDLE fits the window."
(not (mm-long-lines-p 76))))))
(declare-function libxml-parse-html-region "xml.c"
- (start end &optional base-url))
+ (start end &optional base-url discard-comments))
(declare-function shr-insert-document "shr" (dom))
(defvar shr-blocked-images)
(defvar shr-use-fonts)
-(defvar gnus-inhibit-images)
-(autoload 'gnus-blocked-images "gnus-art")
(defun mm-shr (handle)
;; Require since we bind its variables.
(require 'shr)
- (let ((article-buffer (current-buffer))
- (shr-width (if (and (boundp 'shr-use-fonts)
- shr-use-fonts)
+ (let ((shr-width (if shr-use-fonts
nil
fill-column))
(shr-content-function (lambda (id)
(when handle
(mm-with-part handle
(buffer-string))))))
- shr-inhibit-images shr-blocked-images charset char)
- (if (and (boundp 'gnus-summary-buffer)
- (bufferp gnus-summary-buffer)
- (buffer-name gnus-summary-buffer))
- (with-current-buffer gnus-summary-buffer
- (setq shr-inhibit-images gnus-inhibit-images
- shr-blocked-images (gnus-blocked-images)))
- (setq shr-inhibit-images gnus-inhibit-images
- shr-blocked-images (gnus-blocked-images)))
+ (shr-inhibit-images mm-html-inhibit-images)
+ (shr-blocked-images mm-html-blocked-images)
+ charset char)
(unless handle
(setq handle (mm-dissect-buffer t)))
(setq charset (mail-content-type-get (mm-handle-type handle) 'charset))
(mm-charset-to-coding-system charset
nil t))
(not (eq charset 'ascii)))
- (mm-decode-coding-string (buffer-string) charset)
- (mm-string-as-multibyte (buffer-string)))
+ (decode-coding-string (buffer-string) charset)
+ (string-as-multibyte (buffer-string)))
(erase-buffer)
(mm-enable-multibyte)))
(goto-char (point-min))
,(point-max-marker))))))))
(defvar shr-map)
+(defvar shr-image-map)
(autoload 'widget-convert-button "wid-edit")
(widget-convert-button
'url-link start end
:help-echo (get-text-property start 'help-echo)
- :keymap shr-map
+ ;;; FIXME Should only use the image map on images.
+ :keymap shr-image-map
(get-text-property start 'shr-url))
(put-text-property start end 'local-map nil)
- (dolist (overlay (gnus-overlays-at start))
- (gnus-overlay-put overlay 'face nil))
+ (dolist (overlay (overlays-at start))
+ (overlay-put overlay 'face nil))
(setq start end)))))
(defun mm-handle-filename (handle)