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