X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-image.el;h=915fa35601da6af80cdc724fed4747e8d5892b8a;hb=59c2dc20c261303c6d051416e38f30ab94cceb39;hp=dfcfdf9753c7bb0cd89469dbceece5a254032c8e;hpb=72b615491650f92cea4a9a358457d0a32cb8df81;p=elisp%2Fsemi.git diff --git a/mime-image.el b/mime-image.el index dfcfdf9..915fa35 100644 --- a/mime-image.el +++ b/mime-image.el @@ -1,18 +1,18 @@ ;;; mime-image.el --- mime-view filter to display images -;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko +;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko ;; Copyright (C) 1996 Dan Rich ;; Author: MORIOKA Tomohiko -;; Dan Rich -;; Maintainer: MORIOKA Tomohiko +;; Dan Rich +;; Daiki Ueno +;; Katsumi Yamaoka ;; Created: 1995/12/15 ;; Renamed: 1997/2/21 from tm-image.el -;; Version: $Id: mime-image.el,v 0.1 1997-02-21 06:43:51 tmorioka Exp $ ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news -;; This file is part of XEmacs. +;; This file is part of SEMI (Showy Emacs MIME Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -26,8 +26,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; If you use this program with MULE, please install @@ -35,187 +35,173 @@ ;;; Code: -(require 'mime-view) +(eval-when-compile (require 'cl)) -(cond (running-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 bitmap-insert-xbm-file (file) - (let ((gl (make-glyph (list (cons 'x file)))) - (e (make-extent (point) (point))) - ) - (set-extent-end-glyph e gl) - )) - - ;; - ;; X-Face - ;; - (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-view-content-header-filter-hook - 'mime-preview/x-face-function-use-highlight-headers) - - ) - ((featurep 'mule) - ;; for MULE 2.* or mule merged EMACS - (require 'x-face-mule) - - (defvar image-native-formats '(xbm)) - - (defun-maybe image-inline-p (format) - (memq format image-native-formats) - ) - - (defun-maybe image-normalize (format data) - (and (eq format 'xbm) - (vector 'xbm ':data data) - )) - - ;; - ;; X-Face - ;; - (if (file-installed-p uncompface-program exec-path) - (add-hook 'mime-view-content-header-filter-hook - 'x-face-decode-message-header) - ) - )) - -(or (fboundp 'image-invalid-glyph-p) - (defsubst image-invalid-glyph-p (glyph) - (or (null (aref glyph 0)) - (null (aref glyph 2)) - (equal (aref glyph 2) "") - )) - ) - -(defvar mime-view-image-converter-alist nil) - -(mapcar (function - (lambda (rule) - (let ((ctype (car rule)) - (format (cdr rule)) - ) - (if (image-inline-p format) - (progn - (set-alist 'mime-view-content-filter-alist - ctype - (function mime-preview/filter-for-image)) - (set-alist 'mime-view-image-converter-alist - ctype format) - (add-to-list - 'mime-view-default-showing-Content-Type-list - ctype) - ) - )))) - '(("image/jpeg" . jpeg) - ("image/gif" . gif) - ("image/tiff" . tiff) - ("image/x-tiff" . tiff) - ("image/xbm" . xbm) - ("image/x-xbm" . xbm) - ("image/x-xpixmap" . xpm) - ("image/x-pic" . pic) - ("image/x-mag" . mag) - )) - -(defvar mime-view-ps-to-gif-command "pstogif") +(eval-when-compile (require 'static)) +(require 'mime-view) +(require 'alist) +(require 'path-util) + +(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 in the buffer: %s" + (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 in the buffer: %s" + (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 (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) + (image gif gif) + (image tiff tiff) + (image x-tiff tiff) + (image xbm xbm) + (image x-xbm xbm) + (image x-xpixmap xpm) + (image png png))) + +(dolist (rule mime-image-format-alist) + (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) -(defun mime-preview/filter-for-image (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-view-code-converter-alist)) - (charset (assoc "charset" params)) - (beg (point-min)) (end (point-max)) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding image...") - (mime-decode-region beg end encoding) - (let* ((minor (assoc-value ctype mime-view-image-converter-alist)) - (gl (image-normalize minor (buffer-string))) - e) - (delete-region (point-min)(point-max)) - (cond ((image-invalid-glyph-p gl) - (setq gl nil) - (message "Invalid glyph!") - ) - ((eq (aref gl 0) 'xbm) - (let ((xbm-file - (make-temp-name (expand-file-name "tm" mime/tmp-dir)))) - (insert (aref gl 2)) - (write-region (point-min)(point-max) xbm-file) - (message "Decoding image...") - (delete-region (point-min)(point-max)) - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - ) - (message "Decoding image... done") - ) - (t - (setq gl (make-glyph gl)) - (setq e (make-extent (point) (point))) - (set-extent-end-glyph e gl) - (message "Decoding image... done") - )) - ) - (insert "\n") - )) - - -;;; @ content filter for Postscript -;;; -;; (for XEmacs 19.14 or later) - -(defun mime-preview/filter-for-application/postscript (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-view-code-converter-alist)) - (beg (point-min)) (end (point-max)) - (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - (ps-file (concat file-base ".ps")) - (gif-file (concat file-base ".gif")) - ) - (remove-text-properties beg end '(face nil)) - (message "Decoding Postscript...") - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) ps-file) - (message "Decoding Postscript...") - (delete-region (point-min)(point-max)) - (call-process mime-view-ps-to-gif-command nil nil nil ps-file) - (set-extent-end-glyph (make-extent (point) (point)) - (make-glyph (vector 'gif :file gif-file))) - (message "Decoding Postscript... done") - (delete-file ps-file) - (delete-file gif-file) - )) - -(set-alist 'mime-view-content-filter-alist - "application/postscript" - (function mime-preview/filter-for-application/postscript)) - -(if (featurep 'gif) - (add-to-list 'mime-view-default-showing-Content-Type-list - "application/postscript") - ) +(defun mime-display-image (entity situation) + (message "Decoding image...") + (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