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 ;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   9 ;; Created: 1995/12/15
  10 ;;      Renamed: 1997/2/21 from tm-image.el
  11
  12 ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
  13
  14 ;; This file is part of SEMI (Showy Emacs MIME Interfaces).
  15
  16 ;; This program is free software; you can redistribute it and/or
  17 ;; modify it under the terms of the GNU General Public License as
  18 ;; published by the Free Software Foundation; either version 2, or (at
  19 ;; your option) any later version.
  20
  21 ;; This program is distributed in the hope that it will be useful, but
  22 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 ;; General Public License for more details.
  25
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU XEmacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30
  31 ;;; Commentary:
  32 ;;      If you use this program with MULE, please install
  33 ;;      etl8x16-bitmap.bdf font included in tl package.
  34
  35 ;;; Code:
  36
  37 (eval-when-compile (require 'static))
  38 (require 'mime-view)
  39 (require 'alist)
  40 (require 'path-util)
  41
  42 (cond
  43  ((featurep 'xemacs)
  44
  45   (require 'images)
  46
  47   (defun-maybe image-inline-p (format)
  48     (or (memq format image-native-formats)
  49         (find-if (function
  50                   (lambda (native)
  51                     (image-converter-chain format native)
  52                     ))
  53                  image-native-formats)
  54         ))
  55
  56   (image-register-netpbm-utilities)
  57   (image-register-converter 'pic 'ppm "pictoppm")
  58   (image-register-converter 'mag 'ppm "magtoppm")
  59
  60   (defun image-insert-at-point (image)
  61     (let ((e (make-extent (point) (point))))
  62       (set-extent-end-glyph e (make-glyph image))))
  63
  64   (defsubst-maybe image-invalid-glyph-p (glyph)
  65     (or (null (aref glyph 0))
  66         (null (aref glyph 2))
  67         (equal (aref glyph 2) "")
  68         ))
  69   )
  70  ((featurep 'mule)
  71
  72   (eval-and-compile
  73     (autoload 'bitmap-insert-xbm-buffer "bitmap")
  74     )
  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   (defun-maybe image-normalize (format data)
  83     (if (memq format '(xbm xpm))
  84         (list 'image ':type format ':data data)
  85       (let ((image-file
  86              (make-temp-name
  87               (expand-file-name "tm" temporary-file-directory))))
  88         (with-temp-buffer
  89           (insert data)
  90           (write-region-as-binary (point-min)(point-max) image-file))
  91         (list 'image ':type format ':file image-file)
  92         )))
  93
  94   (defun image-insert-at-point (image)
  95     (static-if (fboundp 'insert-image)
  96         (unwind-protect
  97             (save-excursion
  98               (static-if (condition-case nil
  99                              (progn (insert-image '(image)) nil)
 100                            (wrong-number-of-arguments t))
 101                   (insert-image image "x")
 102                 (insert-image image))
 103               (insert "\n")
 104               (save-window-excursion
 105                 (set-window-buffer (selected-window)(current-buffer))
 106                 (sit-for 0)))
 107           (let ((file (plist-get (cdr image) ':file)))
 108             (and file (file-exists-p file)
 109                  (delete-file file)
 110                  )))
 111       (when (eq (plist-get (cdr image) ':type) 'xbm)
 112         (save-restriction
 113           (narrow-to-region (point)(point))
 114           (insert (plist-get (cdr image) ':data))
 115           (let ((mark (set-marker (make-marker) (point))))
 116             (bitmap-insert-xbm-buffer (current-buffer))
 117             (delete-region (point-min) mark))
 118           ))))
 119
 120   (defsubst-maybe image-invalid-glyph-p (glyph)
 121     (not (eq 'image (nth 0 glyph))))
 122   ))
 123
 124 ;;
 125 ;; X-Face
 126 ;;
 127
 128 (cond
 129  ((module-installed-p 'highlight-headers)
 130   (eval-and-compile
 131     (autoload 'highlight-headers "highlight-headers"))
 132
 133   (defun mime-preview-x-face-function-use-highlight-headers ()
 134     (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
 135     )
 136   (add-hook 'mime-display-header-hook
 137             'mime-preview-x-face-function-use-highlight-headers)
 138   )
 139  ((featurep 'mule)
 140   (require 'x-face-mule)
 141   (when (exec-installed-p uncompface-program exec-path)
 142     (add-hook 'mime-display-header-hook
 143               'x-face-decode-message-header))
 144   ))
 145
 146 (defvar mime-image-format-alist
 147   '((image jpeg         jpeg)
 148     (image gif          gif)
 149     (image tiff         tiff)
 150     (image x-tiff       tiff)
 151     (image xbm          xbm)
 152     (image x-xbm        xbm)
 153     (image x-xpixmap    xpm)
 154     (image x-pic        pic)
 155     (image x-mag        mag)
 156     (image png          png)))
 157
 158 (dolist (rule mime-image-format-alist)
 159   (let ((type    (car rule))
 160         (subtype (nth 1 rule))
 161         (format  (nth 2 rule)))
 162     (when (image-inline-p format)
 163       (ctree-set-calist-strictly
 164        'mime-preview-condition
 165        (list (cons 'type type)(cons 'subtype subtype)
 166              '(body . visible)
 167              (cons 'body-presentation-method #'mime-display-image)
 168              (cons 'image-format format))
 169        ))))
 170
 171
 172 ;;; @ content filter for images
 173 ;;;
 174 ;;    (for XEmacs 19.12 or later)
 175
 176 (eval-when-compile
 177   (defmacro mime-image-normalize-xbm (entity)
 178     (` (with-temp-buffer
 179          (mime-insert-entity-content (, entity))
 180          (let ((cur (current-buffer))
 181                width height)
 182            (goto-char (point-min))
 183            (search-forward "width ")
 184            (setq width (read cur))
 185            (goto-char (point-min))
 186            (search-forward "height ")
 187            (setq height (read cur))
 188            (goto-char (point-min))
 189            (search-forward "{")
 190            (delete-region (point-min) (point))
 191            (insert "\"")
 192            (search-forward "}")
 193            (delete-region (1- (point)) (point-max))
 194            (insert "\"")
 195            (goto-char (point-min))
 196            (while (re-search-forward "[^\"0-9A-FXa-fx]+" nil t)
 197              (replace-match ""))
 198            (goto-char (point-min))
 199            (while (search-forward "0x" nil t)
 200              (replace-match "\\\\x"))
 201            (goto-char (point-min))
 202            (, (if (featurep 'xemacs)
 203                   (` (vector 'xbm :data
 204                              (list width height (read cur))))
 205                 '(` (image :type xbm :width (, width) :height (, height)
 206                            :data (, (read cur))))))))))
 207   )
 208
 209 (defun mime-display-image (entity situation)
 210   (message "Decoding image...")
 211   (let* ((format (cdr (assq 'image-format situation)))
 212          (image (if (or (featurep 'xemacs) (boundp 'image-types))
 213                     (if (eq 'xbm format)
 214                         (mime-image-normalize-xbm entity)
 215                       (image-normalize format (mime-entity-content entity)))
 216                   (image-normalize format (mime-entity-content entity)))))
 217     (if (image-invalid-glyph-p image)
 218         (message "Invalid glyph!")
 219       (image-insert-at-point image)
 220       (message "Decoding image... done")))
 221   (static-when (featurep 'xemacs)
 222     (insert "\n")))
 223
 224
 225 ;;; @ end
 226 ;;;
 227
 228 (provide 'mime-image)
 229
 230 ;;; mime-image.el ends here