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