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 'static))
  40
  41 (require 'mime-view)
  42 (require 'alist)
  43 (require 'path-util)
  44
  45 (cond
  46  ((featurep 'xemacs)
  47
  48   (require 'images)
  49
  50   (defun-maybe image-inline-p (format)
  51     (or (memq format image-native-formats)
  52         (find-if (function
  53                   (lambda (native)
  54                     (image-converter-chain format native)))
  55                  image-native-formats)))
  56
  57   (image-register-netpbm-utilities)
  58   (image-register-converter 'pic 'ppm "pictoppm")
  59   (image-register-converter 'mag 'ppm "magtoppm")
  60
  61   (defun image-insert-at-point (image)
  62     (let ((e (make-extent (point) (point))))
  63       (set-extent-end-glyph e (make-glyph image))))
  64
  65   (defsubst-maybe image-invalid-glyph-p (glyph)
  66     (or (null (aref glyph 0))
  67         (null (aref glyph 2))
  68         (equal (aref glyph 2) ""))))
  69  ((featurep 'mule)
  70
  71   (eval-when-compile (ignore-errors (require 'image)))
  72
  73   (eval-and-compile
  74     (autoload 'bitmap-insert-xbm-buffer "bitmap"))
  75
  76   (static-if (fboundp 'image-type-available-p)
  77       (defalias-maybe 'image-inline-p 'image-type-available-p)
  78     (defvar image-native-formats '(xbm))
  79     (defun-maybe image-inline-p (format)
  80       (memq format image-native-formats)))
  81
  82   (static-unless (or (not (fboundp 'create-image))
  83                      (memq 'data-p (aref (symbol-function 'create-image) 0)))
  84     (defadvice create-image
  85       (around data-p (file-or-data &optional type data-p &rest props) activate)
  86       (if (ad-get-arg 2)
  87           (setq ad-return-value
  88                 (nconc
  89                  (list 'image ':type (ad-get-arg 1) ':data (ad-get-arg 0))
  90                  props))
  91         (ad-set-args 0 (list (ad-get-arg 0) (ad-get-arg 1) (ad-get-arg 3)))
  92         ad-do-it)))
  93
  94   (defun-maybe image-normalize (format data)
  95     (if (memq format '(xbm xpm))
  96         (create-image data format 'data)
  97       (let ((image-file
  98              (make-temp-name
  99               (expand-file-name "tm" temporary-file-directory))))
 100         (with-temp-buffer
 101           (insert data)
 102           (write-region-as-binary (point-min)(point-max) image-file))
 103         (create-image image-file format))))
 104
 105   (defun image-insert-at-point (image)
 106     (static-if (fboundp 'insert-image)
 107         (unwind-protect
 108             (save-excursion
 109               (static-if (condition-case nil
 110                              (progn (insert-image '(image)) nil)
 111                            (wrong-number-of-arguments t))
 112                   (insert-image image "x")
 113                 (insert-image image))
 114               (insert "\n")
 115               (save-window-excursion
 116                 (set-window-buffer (selected-window)(current-buffer))
 117                 (sit-for 0)))
 118           (let ((file (plist-get (cdr image) ':file)))
 119             (and file (file-exists-p file)
 120                  (delete-file file))))
 121       (when (eq (plist-get (cdr image) ':type) 'xbm)
 122         (save-restriction
 123           (narrow-to-region (point)(point))
 124           (insert (plist-get (cdr image) ':data))
 125           (let ((mark (set-marker (make-marker) (point))))
 126             (bitmap-insert-xbm-buffer (current-buffer))
 127             (delete-region (point-min) mark))))))
 128
 129   (defsubst-maybe image-invalid-glyph-p (glyph)
 130     (not (eq 'image (nth 0 glyph))))))
 131
 132 ;;
 133 ;; X-Face
 134 ;;
 135
 136 (cond
 137  ((module-installed-p 'highlight-headers)
 138   (eval-and-compile
 139     (autoload 'highlight-headers "highlight-headers"))
 140
 141   (defun mime-preview-x-face-function-use-highlight-headers ()
 142     (highlight-headers (point-min) (re-search-forward "^$" nil t) t))
 143   (add-hook 'mime-display-header-hook
 144             'mime-preview-x-face-function-use-highlight-headers))
 145  ((and (featurep 'mule)
 146        (condition-case nil
 147            (require 'x-face-mule)
 148          (file-error nil))
 149        (exec-installed-p uncompface-program exec-path))
 150   (add-hook 'mime-display-header-hook 'x-face-decode-message-header)))
 151
 152 (defvar mime-image-format-alist
 153   '((image jpeg         jpeg)
 154     (image gif          gif)
 155     (image tiff         tiff)
 156     (image x-tiff       tiff)
 157     (image xbm          xbm)
 158     (image x-xbm        xbm)
 159     (image x-xpixmap    xpm)
 160     (image x-pic        pic)
 161     (image x-mag        mag)
 162     (image png          png)))
 163
 164 (dolist (rule mime-image-format-alist)
 165   (let ((type    (car rule))
 166         (subtype (nth 1 rule))
 167         (format  (nth 2 rule)))
 168     (when (image-inline-p format)
 169       (ctree-set-calist-strictly
 170        'mime-preview-condition
 171        (list (cons 'type type)(cons 'subtype subtype)
 172              '(body . visible)
 173              (cons 'body-presentation-method #'mime-display-image)
 174              (cons 'image-format format))))))
 175
 176
 177 ;;; @ content filter for images
 178 ;;;
 179 ;;    (for XEmacs 19.12 or later)
 180
 181 (eval-when-compile
 182   (defmacro mime-image-normalize-xbm (entity)
 183     (` (with-temp-buffer
 184          (mime-insert-entity-content (, entity))
 185          (let ((cur (current-buffer))
 186                width height)
 187            (goto-char (point-min))
 188            (search-forward "width ")
 189            (setq width (read cur))
 190            (goto-char (point-min))
 191            (search-forward "height ")
 192            (setq height (read cur))
 193            (goto-char (point-min))
 194            (search-forward "{")
 195            (delete-region (point-min) (point))
 196            (insert "\"")
 197            (search-forward "}")
 198            (delete-region (1- (point)) (point-max))
 199            (insert "\"")
 200            (goto-char (point-min))
 201            (while (re-search-forward "[^\"0-9A-FXa-fx]+" nil t)
 202              (replace-match ""))
 203            (goto-char (point-min))
 204            (while (search-forward "0x" nil t)
 205              (replace-match "\\\\x"))
 206            (goto-char (point-min))
 207            (, (if (featurep 'xemacs)
 208                   (` (vector 'xbm :data
 209                              (list width height (read cur))))
 210                 '(` (image :type xbm :width (, width) :height (, height)
 211                            :data (, (read cur)))))))))))
 212
 213 (defun mime-display-image (entity situation)
 214   (message "Decoding image...")
 215   (let* ((format (cdr (assq 'image-format situation)))
 216          (image (if (or (featurep 'xemacs) (boundp 'image-types))
 217                     (if (eq 'xbm format)
 218                         (mime-image-normalize-xbm entity)
 219                       (image-normalize format (mime-entity-content entity)))
 220                   (image-normalize format (mime-entity-content entity)))))
 221     (if (image-invalid-glyph-p image)
 222         (message "Invalid glyph!")
 223       (image-insert-at-point image)
 224       (message "Decoding image... done")))
 225   (static-when (featurep 'xemacs)
 226     (insert "\n")))
 227
 228
 229 ;;; @ end
 230 ;;;
 231
 232 (provide 'mime-image)
 233
 234 ;;; mime-image.el ends here