X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-image.el;h=c8843877c21077967974a8b27730ef75f821dc6b;hb=c3427b4cf9557b4458f394a36fb4ec6f8e74d565;hp=bdfe1d870e8f7d3e743cca6d69184e8e0d57ef59;hpb=f88c828889eba80c7ca4aaa6f34dba277668d5f0;p=elisp%2Fsemi.git diff --git a/mime-image.el b/mime-image.el index bdfe1d8..c884387 100644 --- a/mime-image.el +++ b/mime-image.el @@ -5,7 +5,7 @@ ;; Author: MORIOKA Tomohiko ;; Dan Rich -;; Daiki Ueno +;; Daiki Ueno ;; Katsumi Yamaoka ;; Maintainer: MORIOKA Tomohiko ;; Created: 1995/12/15 @@ -36,115 +36,132 @@ ;;; Code: +(eval-when-compile (require 'cl)) + (eval-when-compile (require 'static)) (require 'mime-view) (require 'alist) (require 'path-util) -(cond - ((featurep 'xemacs) - - (require 'images) - - (defun-maybe image-inline-p (format) - (or (memq format image-native-formats) - (find-if (function - (lambda (native) - (image-converter-chain format native) - )) - image-native-formats) - )) - - (image-register-netpbm-utilities) - (image-register-converter 'pic 'ppm "pictoppm") - (image-register-converter 'mag 'ppm "magtoppm") - - (defun image-insert-at-point (image) - (let ((e (make-extent (point) (point)))) - (set-extent-end-glyph e (make-glyph image)))) - - (defsubst-maybe image-invalid-glyph-p (glyph) - (or (null (aref glyph 0)) - (null (aref glyph 2)) - (equal (aref glyph 2) "") - )) - ) - ((featurep 'mule) - - (eval-and-compile - (autoload 'bitmap-insert-xbm-buffer "bitmap") - ) - - (static-if (fboundp 'image-type-available-p) - (defalias-maybe 'image-inline-p 'image-type-available-p) - (defvar image-native-formats '(xbm)) - (defun-maybe image-inline-p (format) - (memq format image-native-formats))) - - (defun-maybe image-normalize (format data) - (if (memq format '(xbm xpm)) - (list 'image ':type format ':data data) - (let ((image-file - (make-temp-name - (expand-file-name "tm" temporary-file-directory)))) - (with-temp-buffer - (insert data) - (write-region-as-binary (point-min)(point-max) image-file)) - (list 'image ':type format ':file image-file) - ))) - - (defun image-insert-at-point (image) - (static-if (fboundp 'insert-image) - (unwind-protect - (save-excursion - (static-if (condition-case nil - (progn (insert-image '(image)) nil) - (wrong-number-of-arguments t)) - (insert-image image "x") - (insert-image image)) - (insert "\n") - (save-window-excursion - (set-window-buffer (selected-window)(current-buffer)) - (sit-for 0))) - (let ((file (plist-get (cdr image) ':file))) - (and file (file-exists-p file) - (delete-file file) - ))) - (when (eq (plist-get (cdr image) ':type) 'xbm) - (save-restriction - (narrow-to-region (point)(point)) - (insert (plist-get (cdr image) ':data)) - (let ((mark (set-marker (make-marker) (point)))) - (bitmap-insert-xbm-buffer (current-buffer)) - (delete-region (point-min) mark)) - )))) - - (defsubst-maybe image-invalid-glyph-p (glyph) - (not (eq 'image (nth 0 glyph)))) - )) - -;; -;; X-Face -;; - -(cond - ((module-installed-p 'highlight-headers) - (eval-and-compile - (autoload 'highlight-headers "highlight-headers")) - - (defun mime-preview-x-face-function-use-highlight-headers () - (highlight-headers (point-min) (re-search-forward "^$" nil t) t) - ) - (add-hook 'mime-display-header-hook - 'mime-preview-x-face-function-use-highlight-headers) - ) - ((featurep 'mule) - (require 'x-face-mule) - (when (exec-installed-p uncompface-program exec-path) - (add-hook 'mime-display-header-hook - 'x-face-decode-message-header)) - )) +(defsubst mime-image-normalize-xbm-buffer (buffer) + (save-excursion + (set-buffer buffer) + (let ((case-fold-search t) width height xbytes right margin) + (goto-char (point-min)) + (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format" (current-buffer))) + (setq width (string-to-int (match-string 1)) + xbytes (/ (+ width 7) 8)) + (goto-char (point-min)) + (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t) + (error "!! Illegal xbm file format" (current-buffer))) + (setq height (string-to-int (match-string 1))) + (goto-char (point-min)) + (re-search-forward "0x[0-9a-f][0-9a-f],") + (delete-region (point-min) (match-beginning 0)) + (goto-char (point-min)) + (while (re-search-forward "[\n\r\t ,;}]" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "0x" nil t) + (replace-match "\\x" nil t)) + (goto-char (point-min)) + (insert "(" (number-to-string width) " " + (number-to-string height) " \"") + (goto-char (point-max)) + (insert "\")") + (goto-char (point-min)) + (read (current-buffer))))) + +(static-if (featurep 'xemacs) + (progn + (defun mime-image-type-available-p (type) + (memq type (image-instantiator-format-list))) + + (defun mime-image-create (file-or-data &optional type data-p &rest props) + (when (and data-p (eq type 'xbm)) + (with-temp-buffer + (insert file-or-data) + (setq file-or-data + (mime-image-normalize-xbm-buffer (current-buffer))))) + (let ((glyph + (make-glyph + (if (and type (mime-image-type-available-p type)) + (vconcat + (list type (if data-p :data :file) file-or-data) + props) + file-or-data)))) + (if (nothing-image-instance-p (ignore-errors + (glyph-image-instance glyph))) nil + glyph))) + + (defun mime-image-insert (image &optional string area) + (let ((extent (make-extent (point) + (progn (and string + (insert string)) + (point))))) + (set-extent-property extent 'invisible t) + (set-extent-end-glyph extent image)))) + (condition-case nil + (progn + (require 'image) + (defalias 'mime-image-type-available-p 'image-type-available-p) + (defun mime-image-create + (file-or-data &optional type data-p &rest props) + (if (and data-p (eq type 'xbm)) + (with-temp-buffer + (insert file-or-data) + (setq file-or-data + (mime-image-normalize-xbm-buffer (current-buffer))) + (apply #'create-image (nth 2 file-or-data) type data-p + (nconc + (list :width (car file-or-data) + :height (nth 1 file-or-data)) + props))) + (apply #'create-image file-or-data type data-p props))) + (defalias 'mime-image-insert 'insert-image)) + (error + (condition-case nil + (progn + (require (if (featurep 'mule) 'bitmap "")) + (defun mime-image-read-xbm-buffer (buffer) + (condition-case nil + (mapconcat #'bitmap-compose + (append (bitmap-decode-xbm + (bitmap-read-xbm-buffer + (current-buffer))) nil) "\n") + (error nil))) + (defun mime-image-insert (image &optional string area) + (insert image))) + (error + (defalias 'mime-image-read-xbm-buffer + 'mime-image-normalize-xbm-buffer) + (defun mime-image-insert (image &optional string area) + (save-restriction + (narrow-to-region (point)(point)) + (let ((face (gensym "mii"))) + (or (facep face) (make-face face)) + (set-face-stipple face image) + (let ((row (make-string (/ (car image) (frame-char-width)) ? )) + (height (/ (nth 1 image) (frame-char-height))) + (i 0)) + (while (< i height) + (set-text-properties (point) (progn (insert row)(point)) + (list 'face face)) + (insert "\n") + (setq i (1+ i))))))))) + + (defun mime-image-type-available-p (type) + (eq type 'xbm)) + + (defun mime-image-create (file-or-data &optional type data-p &rest props) + (when (or (null type) (eq type 'xbm)) + (with-temp-buffer + (if data-p + (insert file-or-data) + (insert-file-contents file-or-data)) + (mime-image-read-xbm-buffer (current-buffer)))))))) (defvar mime-image-format-alist '((image jpeg jpeg) @@ -154,76 +171,35 @@ (image xbm xbm) (image x-xbm xbm) (image x-xpixmap xpm) - (image x-pic pic) - (image x-mag mag) (image png png))) (dolist (rule mime-image-format-alist) - (let ((type (car rule)) - (subtype (nth 1 rule)) - (format (nth 2 rule))) - (when (image-inline-p format) - (ctree-set-calist-strictly - 'mime-preview-condition - (list (cons 'type type)(cons 'subtype subtype) - '(body . visible) - (cons 'body-presentation-method #'mime-display-image) - (cons 'image-format format)) - )))) - + (when (mime-image-type-available-p (nth 2 rule)) + (ctree-set-calist-strictly + 'mime-preview-condition + (list (cons 'type (car rule))(cons 'subtype (nth 1 rule)) + '(body . visible) + (cons 'body-presentation-method #'mime-display-image) + (cons 'image-format (nth 2 rule)))))) + ;;; @ content filter for images ;;; ;; (for XEmacs 19.12 or later) -(eval-when-compile - (defmacro mime-image-normalize-xbm (entity) - (` (with-temp-buffer - (mime-insert-entity-content (, entity)) - (let ((cur (current-buffer)) - width height) - (goto-char (point-min)) - (search-forward "width ") - (setq width (read cur)) - (goto-char (point-min)) - (search-forward "height ") - (setq height (read cur)) - (goto-char (point-min)) - (search-forward "{") - (delete-region (point-min) (point)) - (insert "\"") - (search-forward "}") - (delete-region (1- (point)) (point-max)) - (insert "\"") - (goto-char (point-min)) - (while (re-search-forward "[^\"0-9A-FXa-fx]+" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (search-forward "0x" nil t) - (replace-match "\\\\x")) - (goto-char (point-min)) - (, (if (featurep 'xemacs) - (` (vector 'xbm :data - (list width height (read cur)))) - '(` (image :type xbm :width (, width) :height (, height) - :data (, (read cur)))))))))) - ) - (defun mime-display-image (entity situation) (message "Decoding image...") - (let* ((format (cdr (assq 'image-format situation))) - (image (if (or (featurep 'xemacs) (boundp 'image-types)) - (if (eq 'xbm format) - (mime-image-normalize-xbm entity) - (image-normalize format (mime-entity-content entity))) - (image-normalize format (mime-entity-content entity))))) - (if (image-invalid-glyph-p image) - (message "Invalid glyph!") - (image-insert-at-point image) - (message "Decoding image... done"))) - (static-when (featurep 'xemacs) - (insert "\n"))) - + (condition-case err + (let ((format (cdr (assq 'image-format situation))) + image) + (setq image (mime-image-create (mime-entity-content entity) format 'data)) + (if (null image) + (message "Invalid glyph!") + (save-excursion + (mime-image-insert image) + (insert "\n") + (message "Decoding image...done")))) + (error nil err))) ;;; @ end ;;;