tm-image.el

   1 ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers
   2
   3 ;; Copyright (C) 1995,1996,1997 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 ;; Version: $Id: tm-image.el,v 7.28 1997/02/13 04:39:19 morioka Exp $
  11
  12 ;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news
  13
  14 ;; This file is part of XEmacs.
  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 'tm-view)
  38
  39 (cond (running-xemacs
  40        (require 'images)
  41
  42        (defun-maybe image-inline-p (format)
  43          (or (memq format image-native-formats)
  44              (find-if (function
  45                        (lambda (native)
  46                          (image-converter-chain format native)
  47                          ))
  48                       image-native-formats)
  49              ))
  50
  51        (image-register-netpbm-utilities)
  52        (image-register-converter 'pic 'ppm "pictoppm")
  53        (image-register-converter 'mag 'ppm "magtoppm")
  54
  55        (defun bitmap-insert-xbm-file (file)
  56          (let ((gl (make-glyph (list (cons 'x file))))
  57                (e (make-extent (point) (point)))
  58                )
  59            (set-extent-end-glyph e gl)
  60            ))
  61
  62        ;;
  63        ;; X-Face
  64        ;;
  65        (autoload 'highlight-headers "highlight-headers")
  66
  67        (defun mime-preview/x-face-function-use-highlight-headers ()
  68          (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
  69          )
  70
  71        (add-hook 'mime-viewer/content-header-filter-hook
  72                  'mime-preview/x-face-function-use-highlight-headers)
  73
  74        )
  75       ((featurep 'mule)
  76        ;; for MULE 2.* or mule merged EMACS
  77        (require 'x-face-mule)
  78
  79        (defvar image-native-formats '(xbm))
  80
  81        (defun-maybe image-inline-p (format)
  82          (memq format image-native-formats)
  83          )
  84
  85        (defun-maybe image-normalize (format data)
  86          (and (eq format 'xbm)
  87               (vector 'xbm ':data data)
  88               ))
  89
  90        ;;
  91        ;; X-Face
  92        ;;
  93        (if (file-installed-p uncompface-program exec-path)
  94            (add-hook 'mime-viewer/content-header-filter-hook
  95                      'x-face-decode-message-header)
  96          )
  97        ))
  98
  99 (or (fboundp 'image-invalid-glyph-p)
 100     (defsubst image-invalid-glyph-p (glyph)
 101       (or (null (aref glyph 0))
 102           (null (aref glyph 2))
 103           (equal (aref glyph 2) "")
 104           ))
 105     )
 106
 107 (defvar mime-viewer/image-converter-alist nil)
 108
 109 (mapcar (function
 110          (lambda (rule)
 111            (let ((ctype  (car rule))
 112                  (format (cdr rule))
 113                  )
 114              (if (image-inline-p format)
 115                  (progn
 116                    (set-alist 'mime-viewer/content-filter-alist
 117                               ctype
 118                               (function mime-preview/filter-for-image))
 119                    (set-alist 'mime-viewer/image-converter-alist
 120                               ctype format)
 121                    (add-to-list
 122                     'mime-viewer/default-showing-Content-Type-list
 123                     ctype)
 124                    )
 125                ))))
 126         '(("image/jpeg"                 . jpeg)
 127           ("image/gif"                  . gif)
 128           ("image/tiff"                 . tiff)
 129           ("image/x-tiff"               . tiff)
 130           ("image/xbm"                  . xbm)
 131           ("image/x-xbm"                . xbm)
 132           ("image/x-xpixmap"            . xpm)
 133           ("image/x-pic"                . pic)
 134           ("image/x-mag"                . mag)
 135           ))
 136
 137 (defvar mime-viewer/ps-to-gif-command "pstogif")
 138
 139
 140 ;;; @ content filter for images
 141 ;;;
 142 ;;    (for XEmacs 19.12 or later)
 143
 144 (defun mime-preview/filter-for-image (ctype params encoding)
 145   (let* ((mode mime::preview/original-major-mode)
 146          (m (assq mode mime-viewer/code-converter-alist))
 147          (charset (assoc "charset" params))
 148          (beg (point-min)) (end (point-max))
 149          )
 150     (remove-text-properties beg end '(face nil))
 151     (message "Decoding image...")
 152     (mime-decode-region beg end encoding)
 153     (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist))
 154            (gl (image-normalize minor (buffer-string)))
 155            e)
 156       (delete-region (point-min)(point-max))
 157       (cond ((image-invalid-glyph-p gl)
 158              (setq gl nil)
 159              (message "Invalid glyph!")
 160              )
 161             ((eq (aref gl 0) 'xbm)
 162              (let ((xbm-file
 163                     (make-temp-name (expand-file-name "tm" mime/tmp-dir))))
 164                (insert (aref gl 2))
 165                (write-region (point-min)(point-max) xbm-file)
 166                (message "Decoding image...")
 167                (delete-region (point-min)(point-max))
 168                (bitmap-insert-xbm-file xbm-file)
 169                (delete-file xbm-file)
 170                )
 171              (message "Decoding image... done")
 172              )
 173             (t
 174              (setq gl (make-glyph gl))
 175              (setq e (make-extent (point) (point)))
 176              (set-extent-end-glyph e gl)
 177              (message "Decoding image... done")
 178              ))
 179       )
 180     (insert "\n")
 181     ))
 182
 183
 184 ;;; @ content filter for Postscript
 185 ;;;
 186 ;;    (for XEmacs 19.14 or later)
 187
 188 (defun mime-preview/filter-for-application/postscript (ctype params encoding)
 189   (let* ((mode mime::preview/original-major-mode)
 190          (m (assq mode mime-viewer/code-converter-alist))
 191          (beg (point-min)) (end (point-max))
 192          (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
 193          (ps-file (concat file-base ".ps"))
 194          (gif-file (concat file-base ".gif"))
 195          )
 196     (remove-text-properties beg end '(face nil))
 197     (message "Decoding Postscript...")
 198     (mime-decode-region beg end encoding)
 199     (write-region (point-min)(point-max) ps-file)
 200     (message "Decoding Postscript...")
 201     (delete-region (point-min)(point-max))
 202     (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file)
 203     (set-extent-end-glyph (make-extent (point) (point))
 204                           (make-glyph (vector 'gif :file gif-file)))
 205     (message "Decoding Postscript... done")
 206     (delete-file ps-file)
 207     (delete-file gif-file)
 208     ))
 209
 210 (set-alist 'mime-viewer/content-filter-alist
 211            "application/postscript"
 212            (function mime-preview/filter-for-application/postscript))
 213
 214 (if (featurep 'gif)
 215     (add-to-list 'mime-viewer/default-showing-Content-Type-list
 216                  "application/postscript")
 217   )
 218
 219
 220 ;;; @ end
 221 ;;;
 222
 223 (provide 'tm-image)
 224
 225 ;;; tm-image.el ends here