mime-image.el

   1 ;;; mime-image.el --- mime-view filter to display images
   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 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  11 ;; Created: 1995/12/15
  12 ;;      Renamed: 1997/2/21 from tm-image.el
  13
  14 ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
  15
  16 ;; This file is part of SEMI (Showy Emacs MIME Interfaces).
  17
  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.
  22
  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.
  27
  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.
  32
  33 ;;; Commentary:
  34 ;;      If you use this program with MULE, please install
  35 ;;      etl8x16-bitmap.bdf font included in tl package.
  36
  37 ;;; Code:
  38
  39 (eval-when-compile (require 'cl))
  40
  41 (eval-when-compile (require 'static))
  42
  43 (require 'mime-view)
  44 (require 'alist)
  45 (require 'path-util)
  46
  47 (defsubst mime-image-normalize-xbm-buffer (buffer)
  48   (save-excursion
  49     (set-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)
  65         (replace-match ""))
  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))
  73       (insert "\")")
  74       (goto-char (point-min))
  75       (read (current-buffer)))))
  76
  77 (static-if (featurep 'xemacs)
  78     (progn
  79       (defun mime-image-type-available-p (type)
  80         (memq type (image-instantiator-format-list)))
  81
  82       (defun mime-image-create (file-or-data &optional type data-p &rest props)
  83         (when (and data-p (eq type 'xbm))
  84           (with-temp-buffer
  85             (insert file-or-data)
  86             (setq file-or-data
  87                   (mime-image-normalize-xbm-buffer (current-buffer)))))
  88         (let ((instance
  89                (make-image-instance
  90                 (if (and type (mime-image-type-available-p type))
  91                     (vconcat
  92                      (list type (if data-p :data :file) file-or-data)
  93                      props)
  94                   file-or-data)
  95                 nil nil 'noerror)))
  96           (if (nothing-image-instance-p instance) nil
  97             (make-glyph instance))))
  98
  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))))
 103   (condition-case nil
 104       (progn
 105         (require '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))
 110               (with-temp-buffer
 111                 (insert file-or-data)
 112                 (setq file-or-data
 113                       (mime-image-normalize-xbm-buffer (current-buffer)))
 114                 (apply #'create-image (nth 2 file-or-data) type data-p
 115                        (nconc
 116                         (list :width (car file-or-data)
 117                               :height (nth 1 file-or-data))
 118                         props)))
 119             (apply #'create-image file-or-data type data-p props)))
 120         (defalias 'mime-image-insert 'insert-image))
 121     (error
 122      (condition-case nil
 123          (progn
 124            (require (if (featurep 'mule) 'bitmap ""))
 125            (defun mime-image-read-xbm-buffer (buffer)
 126              (condition-case nil
 127                  (mapconcat #'bitmap-compose
 128                             (append (bitmap-decode-xbm
 129                                      (bitmap-read-xbm-buffer
 130                                       (current-buffer))) nil) "\n")
 131                (error nil)))
 132            (defun mime-image-insert (image string &optional area)
 133              (insert image)))
 134        (error
 135         (defalias 'mime-image-read-xbm-buffer
 136           'mime-image-normalize-xbm-buffer)
 137         (defun mime-image-insert (image string &optional area)
 138           (save-restriction
 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)))
 145                   (i 0))
 146                 (while (< i height)
 147                   (set-text-properties (point) (progn (insert row)(point))
 148                                        (list 'face face))
 149                   (insert "\n")
 150                   (setq i (1+ i)))))))))
 151
 152      (defun mime-image-type-available-p (type)
 153        (eq type 'xbm))
 154
 155      (defun mime-image-create (file-or-data &optional type data-p &rest props)
 156        (when (or (null type) (eq type 'xbm))
 157          (with-temp-buffer
 158            (if data-p
 159                (insert file-or-data)
 160              (insert-file-contents file-or-data))
 161            (mime-image-read-xbm-buffer (current-buffer))))))))
 162
 163 (defvar mime-image-format-alist
 164   '((image jpeg         jpeg)
 165     (image gif          gif)
 166     (image tiff         tiff)
 167     (image x-tiff       tiff)
 168     (image xbm          xbm)
 169     (image x-xbm        xbm)
 170     (image x-xpixmap    xpm)
 171     (image png          png)))
 172
 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))
 178            '(body . visible)
 179            (cons 'body-presentation-method #'mime-display-image)
 180            (cons 'image-format (nth 2 rule))))))
 181
 182
 183 ;;; @ content filter for images
 184 ;;;
 185 ;;    (for XEmacs 19.12 or later)
 186
 187 (defun mime-display-image (entity situation)
 188   (message "Decoding image...")
 189   (let ((format (cdr (assq 'image-format situation)))
 190         image)
 191     (setq image (mime-image-create (mime-entity-content entity) format 'data))
 192     (if (null image)
 193         (message "Invalid glyph!")
 194       (save-excursion
 195         (mime-image-insert image "x")
 196         (insert "\n")
 197         (message "Decoding image... done")))))
 198
 199 ;;; @ end
 200 ;;;
 201
 202 (provide 'mime-image)
 203
 204 ;;; mime-image.el ends here