mime-image.el

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