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 (static-if (featurep 'xemacs)
  48     (progn
  49       (defun mime-image-type-available-p (type)
  50         (memq type (image-instantiator-format-list)))
  51
  52       (defun mime-image-create (file-or-data &optional type data-p &rest props)
  53         (let ((instance
  54                (make-image-instance
  55                 (if (and type (mime-image-type-available-p type))
  56                     (vector type (if data-p :data :file) file-or-data)
  57                   file-or-data)
  58                 nil nil 'noerror)))
  59           (if (eq 'nothing (image-instance-type instance)) nil
  60             (make-glyph instance))))
  61
  62       (defun mime-image-insert (image string &optional area)
  63         (let ((extent (make-extent (point) (progn (insert string)(point)))))
  64           (set-extent-property extent 'invisible t)
  65           (set-extent-end-glyph extent image))))
  66   (condition-case nil
  67       (progn
  68         (require 'image)
  69         (defalias 'mime-image-type-available-p 'image-type-available-p)
  70         (defalias 'mime-image-create 'create-image)
  71         (defalias 'mime-image-insert 'insert-image))
  72     (error
  73      (condition-case nil
  74          (progn
  75            (require (if (featurep 'mule) 'bitmap ""))
  76            (defun mime-image-read-xbm-buffer (buffer)
  77              (condition-case nil
  78                  (mapconcat #'bitmap-compose
  79                             (append (bitmap-decode-xbm
  80                                      (bitmap-read-xbm-buffer
  81                                       (current-buffer))) nil) "\n")
  82                (error nil)))
  83            (defun mime-image-insert (image string &optional area)
  84              (insert image)))
  85        (error
  86         (defun mime-image-read-xbm-buffer (buffer)
  87           (save-excursion
  88             (set-buffer buffer)
  89             (let ((case-fold-search t) width height xbytes right margin)
  90               (goto-char (point-min))
  91               (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
  92                   (error "!! Illegal xbm file format" (current-buffer)))
  93               (setq width (string-to-int (match-string 1))
  94                     xbytes (/ (+ width 7) 8))
  95               (goto-char (point-min))
  96               (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
  97                   (error "!! Illegal xbm file format" (current-buffer)))
  98               (setq height (string-to-int (match-string 1)))
  99               (goto-char (point-min))
 100               (re-search-forward "0x[0-9a-f][0-9a-f],")
 101               (delete-region (point-min) (match-beginning 0))
 102               (goto-char (point-min))
 103               (while (re-search-forward "[\n\r\t ,;}]" nil t)
 104                 (replace-match ""))
 105               (goto-char (point-min))
 106               (while (re-search-forward "0x" nil t)
 107                 (replace-match "\\x" nil t))
 108               (goto-char (point-min))
 109               (insert "(" (number-to-string width) " "
 110                       (number-to-string height) " \"")
 111               (goto-char (point-max))
 112               (insert "\")")
 113               (goto-char (point-min))
 114               (read (current-buffer)))))
 115
 116         (defun mime-image-insert (image string &optional area)
 117           (save-restriction
 118             (narrow-to-region (point)(point))
 119             (let ((face (gensym "mis")))
 120               (or (facep face) (make-face face))
 121               (set-face-stipple face image)
 122               (let ((row (make-string (/ (car image)  (frame-char-width)) ? ))
 123                   (height (/ (nth 1 image)  (frame-char-height)))
 124                   (i 0))
 125                 (while (< i height)
 126                   (set-text-properties (point) (progn (insert row)(point))
 127                                        (list 'face face))
 128                   (insert "\n")
 129                   (setq i (1+ i)))))))))
 130
 131      (defun mime-image-type-available-p (type)
 132        (eq type 'xbm))
 133
 134      (defun mime-image-create (file-or-data &optional type data-p &rest props)
 135        (when (or (null type) (eq type 'xbm))
 136          (with-temp-buffer
 137            (if data-p
 138                (insert file-or-data)
 139              (insert-file-contents file-or-data))
 140            (mime-image-read-xbm-buffer (current-buffer))))))))
 141
 142 (defvar mime-image-format-alist
 143   '((image jpeg         jpeg)
 144     (image gif          gif)
 145     (image tiff         tiff)
 146     (image x-tiff       tiff)
 147     (image xbm          xbm)
 148     (image x-xbm        xbm)
 149     (image x-xpixmap    xpm)
 150     (image png          png)))
 151
 152 (dolist (rule mime-image-format-alist)
 153   (when (mime-image-type-available-p (nth 2 rule))
 154     (ctree-set-calist-strictly
 155      'mime-preview-condition
 156      (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
 157            '(body . visible)
 158            (cons 'body-presentation-method #'mime-display-image)
 159            (cons 'image-format (nth 2 rule))))))
 160
 161
 162 ;;; @ content filter for images
 163 ;;;
 164 ;;    (for XEmacs 19.12 or later)
 165
 166 (defun mime-display-image (entity situation)
 167   (message "Decoding image...")
 168   (let ((format (cdr (assq 'image-format situation)))
 169         (image-file
 170          (make-temp-name (expand-file-name "tm" temporary-file-directory)))
 171         image)
 172     (unwind-protect
 173         (progn
 174           (mime-write-entity-content entity image-file)
 175           (if (null (setq image (mime-image-create image-file format)))
 176               (message "Invalid glyph!")
 177             (save-excursion
 178               (mime-image-insert image "x")
 179               (insert "\n")
 180               (save-window-excursion
 181                 (set-window-buffer (selected-window)(current-buffer))
 182                 (sit-for 0))
 183               (message "Decoding image... done"))))
 184       (condition-case nil
 185           (delete-file image-file)
 186         (error nil)))))
 187
 188 ;;; @ end
 189 ;;;
 190
 191 (provide 'mime-image)
 192
 193 ;;; mime-image.el ends here