1 ;;; mime-image.el --- mime-view filter to display images
3 ;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
4 ;; Copyright (C) 1996 Dan Rich
6 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;; Dan Rich <drich@morpheus.corp.sgi.com>
8 ;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
9 ;; Katsumi Yamaoka <yamaoka@jpl.org>
10 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
11 ;; Created: 1995/12/15
12 ;; Renamed: 1997/2/21 from tm-image.el
14 ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
16 ;; This file is part of SEMI (Showy Emacs MIME Interfaces).
18 ;; This program is free software; you can redistribute it and/or
19 ;; modify it under the terms of the GNU General Public License as
20 ;; published by the Free Software Foundation; either version 2, or (at
21 ;; your option) any later version.
23 ;; This program is distributed in the hope that it will be useful, but
24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
26 ;; General Public License for more details.
28 ;; You should have received a copy of the GNU General Public License
29 ;; along with GNU XEmacs; see the file COPYING. If not, write to the
30 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
31 ;; Boston, MA 02111-1307, USA.
34 ;; If you use this program with MULE, please install
35 ;; etl8x16-bitmap.bdf font included in tl package.
39 (eval-when-compile (require 'cl))
41 (eval-when-compile (require 'static))
47 (defsubst mime-image-normalize-xbm-buffer (buffer)
50 (let ((case-fold-search t) width height xbytes right margin)
51 (goto-char (point-min))
52 (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
53 (error "!! Illegal xbm file format" (current-buffer)))
54 (setq width (string-to-int (match-string 1))
55 xbytes (/ (+ width 7) 8))
56 (goto-char (point-min))
57 (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
58 (error "!! Illegal xbm file format" (current-buffer)))
59 (setq height (string-to-int (match-string 1)))
60 (goto-char (point-min))
61 (re-search-forward "0x[0-9a-f][0-9a-f],")
62 (delete-region (point-min) (match-beginning 0))
63 (goto-char (point-min))
64 (while (re-search-forward "[\n\r\t ,;}]" nil t)
66 (goto-char (point-min))
67 (while (re-search-forward "0x" nil t)
68 (replace-match "\\x" nil t))
69 (goto-char (point-min))
70 (insert "(" (number-to-string width) " "
71 (number-to-string height) " \"")
72 (goto-char (point-max))
74 (goto-char (point-min))
75 (read (current-buffer)))))
77 (static-if (featurep 'xemacs)
79 (defun mime-image-type-available-p (type)
80 (memq type (image-instantiator-format-list)))
82 (defun mime-image-create (file-or-data &optional type data-p &rest props)
83 (when (and data-p (eq type 'xbm))
87 (mime-image-normalize-xbm-buffer (current-buffer)))))
90 (if (and type (mime-image-type-available-p type))
92 (list type (if data-p :data :file) file-or-data)
96 (if (nothing-image-instance-p instance) nil
97 (make-glyph instance))))
99 (defun mime-image-insert (image string &optional area)
100 (let ((extent (make-extent (point) (progn (insert string)(point)))))
101 (set-extent-property extent 'invisible t)
102 (set-extent-end-glyph extent image))))
106 (defalias 'mime-image-type-available-p 'image-type-available-p)
107 (defun mime-image-create
108 (file-or-data &optional type data-p &rest props)
109 (if (and data-p (eq type 'xbm))
111 (insert file-or-data)
113 (mime-image-normalize-xbm-buffer (current-buffer)))
114 (apply #'create-image (nth 2 file-or-data) type data-p
116 (list :width (car file-or-data)
117 :height (nth 1 file-or-data))
119 (apply #'create-image file-or-data type data-p props)))
120 (defalias 'mime-image-insert 'insert-image))
124 (require (if (featurep 'mule) 'bitmap ""))
125 (defun mime-image-read-xbm-buffer (buffer)
127 (mapconcat #'bitmap-compose
128 (append (bitmap-decode-xbm
129 (bitmap-read-xbm-buffer
130 (current-buffer))) nil) "\n")
132 (defun mime-image-insert (image string &optional area)
135 (defalias 'mime-image-read-xbm-buffer
136 'mime-image-normalize-xbm-buffer)
137 (defun mime-image-insert (image string &optional area)
139 (narrow-to-region (point)(point))
140 (let ((face (gensym "mii")))
141 (or (facep face) (make-face face))
142 (set-face-stipple face image)
143 (let ((row (make-string (/ (car image) (frame-char-width)) ? ))
144 (height (/ (nth 1 image) (frame-char-height)))
147 (set-text-properties (point) (progn (insert row)(point))
150 (setq i (1+ i)))))))))
152 (defun mime-image-type-available-p (type)
155 (defun mime-image-create (file-or-data &optional type data-p &rest props)
156 (when (or (null type) (eq type 'xbm))
159 (insert file-or-data)
160 (insert-file-contents file-or-data))
161 (mime-image-read-xbm-buffer (current-buffer))))))))
163 (defvar mime-image-format-alist
170 (image x-xpixmap xpm)
173 (dolist (rule mime-image-format-alist)
174 (when (mime-image-type-available-p (nth 2 rule))
175 (ctree-set-calist-strictly
176 'mime-preview-condition
177 (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
179 (cons 'body-presentation-method #'mime-display-image)
180 (cons 'image-format (nth 2 rule))))))
183 ;;; @ content filter for images
185 ;; (for XEmacs 19.12 or later)
187 (defun mime-display-image (entity situation)
188 (message "Decoding image...")
189 (let ((format (cdr (assq 'image-format situation)))
191 (setq image (mime-image-create (mime-entity-content entity) format 'data))
193 (message "Invalid glyph!")
195 (mime-image-insert image "x")
197 (save-window-excursion
198 (set-window-buffer (selected-window)(current-buffer))
200 (message "Decoding image... done")))))
205 (provide 'mime-image)
207 ;;; mime-image.el ends here