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 (require 'mime-view)
  38 (require 'alist)
  39
  40 (cond ((featurep 'xemacs)
  41        (require 'images)
  42
  43        (defun-maybe image-inline-p (format)
  44          (or (memq format image-native-formats)
  45              (find-if (function
  46                        (lambda (native)
  47                          (image-converter-chain format native)
  48                          ))
  49                       image-native-formats)
  50              ))
  51
  52        (image-register-netpbm-utilities)
  53        (image-register-converter 'pic 'ppm "pictoppm")
  54        (image-register-converter 'mag 'ppm "magtoppm")
  55
  56        (defun bitmap-insert-xbm-file (file)
  57          (let ((gl (make-glyph (list (cons 'x file))))
  58                (e (make-extent (point) (point)))
  59                )
  60            (set-extent-end-glyph e gl)
  61            ))
  62
  63        ;;
  64        ;; X-Face
  65        ;;
  66        (autoload 'highlight-headers "highlight-headers")
  67
  68        (defun mime-preview-x-face-function-use-highlight-headers ()
  69          (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
  70          )
  71
  72        (add-hook 'mime-display-header-hook
  73                  'mime-preview-x-face-function-use-highlight-headers)
  74
  75        )
  76       ((featurep 'mule)
  77        ;; for MULE 2.* or mule merged EMACS
  78        (require 'x-face-mule)
  79
  80        (defvar image-native-formats '(xbm))
  81
  82        (defun-maybe image-inline-p (format)
  83          (memq format image-native-formats)
  84          )
  85
  86        (defun-maybe image-normalize (format data)
  87          (and (eq format 'xbm)
  88               (vector 'xbm ':data data)
  89               ))
  90
  91        ;;
  92        ;; X-Face
  93        ;;
  94        (if (exec-installed-p uncompface-program exec-path)
  95            (add-hook 'mime-display-header-hook
  96                      'x-face-decode-message-header)
  97          )
  98        ))
  99
 100 (or (fboundp 'image-invalid-glyph-p)
 101     (defsubst image-invalid-glyph-p (glyph)
 102       (or (null (aref glyph 0))
 103           (null (aref glyph 2))
 104           (equal (aref glyph 2) "")
 105           ))
 106     )
 107
 108 (mapcar (function
 109          (lambda (rule)
 110            (let ((type    (car rule))
 111                  (subtype (nth 1 rule))
 112                  (format  (nth 2 rule)))
 113              (if (image-inline-p format)
 114                  (ctree-set-calist-strictly
 115                   'mime-preview-condition
 116                   (list (cons 'type type)(cons 'subtype subtype)
 117                         '(body . visible)
 118                         (cons 'body-presentation-method #'mime-display-image)
 119                         (cons 'image-format format))
 120                   )))))
 121         '((image jpeg           jpeg)
 122           (image gif            gif)
 123           (image tiff           tiff)
 124           (image x-tiff         tiff)
 125           (image xbm            xbm)
 126           (image x-xbm          xbm)
 127           (image x-xpixmap      xpm)
 128           (image x-pic          pic)
 129           (image x-mag          mag)
 130           (image png            png)
 131           ))
 132
 133
 134 ;;; @ content filter for images
 135 ;;;
 136 ;;    (for XEmacs 19.12 or later)
 137
 138 (defun mime-display-image (entity situation)
 139   (message "Decoding image...")
 140   (let ((gl (image-normalize (cdr (assq 'image-format situation))
 141                              (mime-entity-content entity))))
 142     (cond ((image-invalid-glyph-p gl)
 143            (setq gl nil)
 144            (message "Invalid glyph!")
 145            )
 146           ((eq (aref gl 0) 'xbm)
 147            (let ((xbm-file
 148                   (make-temp-name
 149                    (expand-file-name "tm" temporary-file-directory))))
 150              (with-temp-buffer
 151                (insert (aref gl 2))
 152                (write-region (point-min)(point-max) xbm-file)
 153                )
 154              (message "Decoding image...")
 155              (bitmap-insert-xbm-file xbm-file)
 156              (delete-file xbm-file)
 157              )
 158            (message "Decoding image... done")
 159            )
 160           (t
 161            (setq gl (make-glyph gl))
 162            (let ((e (make-extent (point) (point))))
 163              (set-extent-end-glyph e gl)
 164              )
 165            (message "Decoding image... done")
 166            ))
 167     )
 168   (insert "\n")
 169   )
 170
 171
 172 ;;; @ end
 173 ;;;
 174
 175 (provide 'mime-image)
 176
 177 ;;; mime-image.el ends here