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 ((glyph
  89                (make-glyph
  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           (if (nothing-image-instance-p (glyph-image-instance glyph)) nil
  96             glyph)))
  97
  98       (defun mime-image-insert (image &optional string area)
  99         (let ((extent (make-extent (point)
 100                                    (progn (and string
 101                                                (insert string))
 102                                           (point)))))
 103           (set-extent-property extent 'invisible t)
 104           (set-extent-end-glyph extent image))))
 105   (condition-case nil
 106       (progn
 107         (require 'image)
 108         (defalias 'mime-image-type-available-p 'image-type-available-p)
 109         (defun mime-image-create
 110           (file-or-data &optional type data-p &rest props)
 111           (if (and data-p (eq type 'xbm))
 112               (with-temp-buffer
 113                 (insert file-or-data)
 114                 (setq file-or-data
 115                       (mime-image-normalize-xbm-buffer (current-buffer)))
 116                 (apply #'create-image (nth 2 file-or-data) type data-p
 117                        (nconc
 118                         (list :width (car file-or-data)
 119                               :height (nth 1 file-or-data))
 120                         props)))
 121             (apply #'create-image file-or-data type data-p props)))
 122         (defalias 'mime-image-insert 'insert-image))
 123     (error
 124      (condition-case nil
 125          (progn
 126            (require (if (featurep 'mule) 'bitmap ""))
 127            (defun mime-image-read-xbm-buffer (buffer)
 128              (condition-case nil
 129                  (mapconcat #'bitmap-compose
 130                             (append (bitmap-decode-xbm
 131                                      (bitmap-read-xbm-buffer
 132                                       (current-buffer))) nil) "\n")
 133                (error nil)))
 134            (defun mime-image-insert (image &optional string area)
 135              (insert image)))
 136        (error
 137         (defalias 'mime-image-read-xbm-buffer
 138           'mime-image-normalize-xbm-buffer)
 139         (defun mime-image-insert (image &optional string area)
 140           (save-restriction
 141             (narrow-to-region (point)(point))
 142             (let ((face (gensym "mii")))
 143               (or (facep face) (make-face face))
 144               (set-face-stipple face image)
 145               (let ((row (make-string (/ (car image)  (frame-char-width)) ? ))
 146                   (height (/ (nth 1 image)  (frame-char-height)))
 147                   (i 0))
 148                 (while (< i height)
 149                   (set-text-properties (point) (progn (insert row)(point))
 150                                        (list 'face face))
 151                   (insert "\n")
 152                   (setq i (1+ i)))))))))
 153
 154      (defun mime-image-type-available-p (type)
 155        (eq type 'xbm))
 156
 157      (defun mime-image-create (file-or-data &optional type data-p &rest props)
 158        (when (or (null type) (eq type 'xbm))
 159          (with-temp-buffer
 160            (if data-p
 161                (insert file-or-data)
 162              (insert-file-contents file-or-data))
 163            (mime-image-read-xbm-buffer (current-buffer))))))))
 164
 165 (defvar mime-image-format-alist
 166   '((image jpeg         jpeg)
 167     (image gif          gif)
 168     (image tiff         tiff)
 169     (image x-tiff       tiff)
 170     (image xbm          xbm)
 171     (image x-xbm        xbm)
 172     (image x-xpixmap    xpm)
 173     (image png          png)))
 174
 175 (dolist (rule mime-image-format-alist)
 176   (when (mime-image-type-available-p (nth 2 rule))
 177     (ctree-set-calist-strictly
 178      'mime-preview-condition
 179      (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
 180            '(body . visible)
 181            (cons 'body-presentation-method #'mime-display-image)
 182            (cons 'image-format (nth 2 rule))))))
 183
 184
 185 ;;; @ content filter for images
 186 ;;;
 187 ;;    (for XEmacs 19.12 or later)
 188
 189 (defun mime-display-image (entity situation)
 190   (message "Decoding image...")
 191   (let ((format (cdr (assq 'image-format situation)))
 192         image)
 193     (setq image (mime-image-create (mime-entity-content entity) format 'data))
 194     (if (null image)
 195         (message "Invalid glyph!")
 196       (save-excursion
 197         (mime-image-insert image)
 198         (insert "\n")
 199         (message "Decoding image...done")))))
 200
 201 ;;; @ end
 202 ;;;
 203
 204 (provide 'mime-image)
 205
 206 ;;; mime-image.el ends here