1;;; mime-image.el --- mime-view filter to display images  -*- lexical-binding: t -*-
2
3;; Copyright (C) 1995,1996,1997,1998 MORIOKA Tomohiko
4;; Copyright (C) 1996 Dan Rich
5
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;; Created: 1995/12/15
11;;	Renamed: 1997/2/21 from tm-image.el
12
13;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
14
15;; This file is part of SEMI (Showy Emacs MIME Interfaces).
16
17;; This program is free software; you can redistribute it and/or
18;; modify it under the terms of the GNU General Public License as
19;; published by the Free Software Foundation; either version 2, or (at
20;; your option) any later version.
21
22;; This program is distributed in the hope that it will be useful, but
23;; WITHOUT ANY WARRANTY; without even the implied warranty of
24;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
25;; General Public License for more details.
26
27;; You should have received a copy of the GNU General Public License
28;; along with GNU XEmacs; see the file COPYING.  If not, write to the
29;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30;; Boston, MA 02110-1301, USA.
31
32;;; Commentary:
33;;	If you use this program with MULE, please install
34;;	etl8x16-bitmap.bdf font included in tl package.
35
36;;; Code:
37
38(require 'mime-view)
39(require 'alist)
40(require 'path-util)
41
42(defsubst mime-image-normalize-xbm-buffer ()
43  (save-excursion
44    (let ((case-fold-search t) width height)
45      (goto-char (point-min))
46      (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
47	  (error "!! Illegal xbm file format in the buffer: %s"
48		 (current-buffer)))
49      (setq width (string-to-number (match-string 1)))
50      (goto-char (point-min))
51      (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
52	  (error "!! Illegal xbm file format in the buffer: %s"
53		 (current-buffer)))
54      (setq height (string-to-number (match-string 1)))
55      (goto-char (point-min))
56      (re-search-forward "0x[0-9a-f][0-9a-f],")
57      (delete-region (point-min) (match-beginning 0))
58      (goto-char (point-min))
59      (while (re-search-forward "[\n\r\t ,;}]" nil t)
60	(replace-match ""))
61      (goto-char (point-min))
62      (while (re-search-forward "0x" nil t)
63	(replace-match "\\x" nil t))
64      (goto-char (point-min))
65      (insert "(" (number-to-string width) " "
66	      (number-to-string height) " \"")
67      (goto-char (point-max))
68      (insert "\")")
69      (goto-char (point-min))
70      (read (current-buffer)))))
71
72(defcustom mime-image-max-height nil
73  "*Max displayed image height of attachment image to a message.
74It has effect only when imagemagick or image scaling support is
75available.
76When value is floating-point, it indicates ratio
77to `(frame-pixel-width)'.
78When `mime-image-normalize-xbm' is non-nil, original size is
79always used for xbm image."
80    :group 'mime-view
81    :type '(choice (const :tag "Use original size" nil)
82		   (float :tag "Ratio to frame width")
83		   (integer :tag "Specify in pixel")))
84
85(defcustom mime-image-max-width nil
86  "*Max displayed image width of attachment image to a message.
87It has effect only when imagemagick or image scaling support is
88available.
89When value is floating-point number, it indicates ratio
90to `(frame-pixel-height)'.
91When `mime-image-normalize-xbm' is non-nil, original size is
92always used for xbm image."
93  :group 'mime-view
94  :type '(choice (const :tag "Use original size" nil)
95		 (float :tag "Ratio to frame height")
96		 (integer :tag "Specify in pixel")))
97
98(defcustom mime-image-normalize-xbm t
99  "*When non-nil, build binary xbm image to display.
100Furthermore, image scaling for xbm image is disabled."
101  :group 'mime-view
102  :type 'boolean)
103
104(defalias 'mime-image-type-available-p 'image-type-available-p)
105(defun mime-image-create
106    (file-or-data &optional type data-p &rest props)
107  (let* ((scale-p (and (fboundp 'image-transforms-p)
108		       (memq 'scale (image-transforms-p))))
109	 (imagemagick
110	  (and (null scale-p)
111	       (or mime-image-max-height mime-image-max-width)
112	       (image-type-available-p 'imagemagick)
113	       (fboundp 'imagemagick-filter-types)
114	       (member (downcase (symbol-name type))
115		       (mapcar (lambda (e) (downcase (symbol-name e)))
116			       (imagemagick-filter-types)))))
117	 height width)
118    (when (and mime-image-normalize-xbm data-p (eq type 'xbm))
119      (with-temp-buffer
120	(insert file-or-data)
121	(setq file-or-data
122	      (mime-image-normalize-xbm-buffer)))
123      (setq width (car file-or-data)
124	    height (nth 1 file-or-data)
125	    file-or-data (nth 2 file-or-data)))
126    (setq props
127	  (nconc (and width `(:width ,width))
128		 (and height `(:height ,height))
129		 (and (or scale-p imagemagick)
130		      mime-image-max-width
131		      `(:max-width
132			,(if (integerp mime-image-max-width)
133			     mime-image-max-width
134			   (floor (* (frame-pixel-width)
135				     mime-image-max-width)))))
136		 (and (or scale-p imagemagick)
137		      mime-image-max-height
138		      `(:max-height
139			,(if (integerp mime-image-max-height)
140			     mime-image-max-height
141			   (floor (* (frame-pixel-height)
142				     mime-image-max-height)))))
143		   props))
144    (cond
145     (imagemagick
146      (apply #'create-image file-or-data 'imagemagick data-p props))
147     (t
148      (apply #'create-image file-or-data type data-p props)))))
149(defalias 'mime-image-insert 'insert-image)
150
151(defvar mime-image-format-alist
152  '((image jpeg		jpeg)
153    (image gif		gif)
154    (image tiff		tiff)
155    (image x-tiff	tiff)
156    (image xbm		xbm)
157    (image x-xbm	xbm)
158    (image x-xpixmap	xpm)
159    (image png		png)))
160
161(dolist (rule mime-image-format-alist)
162  (when (mime-image-type-available-p (nth 2 rule))
163    (ctree-set-calist-strictly
164     'mime-preview-condition
165     (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
166	   '(body . visible)
167	   (cons 'body-presentation-method #'mime-display-image)
168	   (cons 'image-format (nth 2 rule))))))
169
170
171;;; @ content filter for images
172;;;
173;;    (for XEmacs 19.12 or later)
174
175(defun mime-display-image (entity situation)
176  (message "Decoding image...")
177  (condition-case err
178      (let ((format (cdr (assq 'image-format situation)))
179	    image)
180	(setq image
181	      (mime-image-create (mime-entity-content entity)
182				 format 'data))
183	(if (null image)
184	    (message "Invalid glyph!")
185	  (save-excursion
186	    (mime-image-insert image)
187	    (insert "\n")
188	    (message "Decoding image...done"))))
189    (error nil err)))
190
191
192;;; @ end
193;;;
194
195(provide 'mime-image)
196
197;;; mime-image.el ends here
198