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.2 1997-02-28 02:22:03 tmorioka 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 (running-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 (file-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-preview/filter-for-image))
 122                    (set-alist 'mime-view-image-converter-alist
 123                               ctype format)
 124                    (add-to-list
 125                     'mime-view-default-showing-Content-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           ))
 139
 140 (defvar mime-view-ps-to-gif-command "pstogif")
 141
 142
 143 ;;; @ content filter for images
 144 ;;;
 145 ;;    (for XEmacs 19.12 or later)
 146
 147 (defun mime-preview/filter-for-image (ctype params encoding)
 148   (let* ((mode mime::preview/original-major-mode)
 149          (m (assq mode mime-view-code-converter-alist))
 150          (charset (assoc "charset" params))
 151          (beg (point-min)) (end (point-max))
 152          )
 153     (remove-text-properties beg end '(face nil))
 154     (message "Decoding image...")
 155     (mime-decode-region beg end encoding)
 156     (let* ((minor (assoc-value ctype mime-view-image-converter-alist))
 157            (gl (image-normalize minor (buffer-string)))
 158            e)
 159       (delete-region (point-min)(point-max))
 160       (cond ((image-invalid-glyph-p gl)
 161              (setq gl nil)
 162              (message "Invalid glyph!")
 163              )
 164             ((eq (aref gl 0) 'xbm)
 165              (let ((xbm-file
 166                     (make-temp-name (expand-file-name "tm" mime/tmp-dir))))
 167                (insert (aref gl 2))
 168                (write-region (point-min)(point-max) xbm-file)
 169                (message "Decoding image...")
 170                (delete-region (point-min)(point-max))
 171                (bitmap-insert-xbm-file xbm-file)
 172                (delete-file xbm-file)
 173                )
 174              (message "Decoding image... done")
 175              )
 176             (t
 177              (setq gl (make-glyph gl))
 178              (setq e (make-extent (point) (point)))
 179              (set-extent-end-glyph e gl)
 180              (message "Decoding image... done")
 181              ))
 182       )
 183     (insert "\n")
 184     ))
 185
 186
 187 ;;; @ content filter for Postscript
 188 ;;;
 189 ;;    (for XEmacs 19.14 or later)
 190
 191 (defun mime-preview/filter-for-application/postscript (ctype params encoding)
 192   (let* ((mode mime::preview/original-major-mode)
 193          (m (assq mode mime-view-code-converter-alist))
 194          (beg (point-min)) (end (point-max))
 195          (file-base (make-temp-name (expand-file-name "tm" mime/tmp-dir)))
 196          (ps-file (concat file-base ".ps"))
 197          (gif-file (concat file-base ".gif"))
 198          )
 199     (remove-text-properties beg end '(face nil))
 200     (message "Decoding Postscript...")
 201     (mime-decode-region beg end encoding)
 202     (write-region (point-min)(point-max) ps-file)
 203     (message "Decoding Postscript...")
 204     (delete-region (point-min)(point-max))
 205     (call-process mime-view-ps-to-gif-command nil nil nil ps-file)
 206     (set-extent-end-glyph (make-extent (point) (point))
 207                           (make-glyph (vector 'gif :file gif-file)))
 208     (message "Decoding Postscript... done")
 209     (delete-file ps-file)
 210     (delete-file gif-file)
 211     ))
 212
 213 (set-alist 'mime-view-content-filter-alist
 214            "application/postscript"
 215            (function mime-preview/filter-for-application/postscript))
 216
 217 (if (featurep 'gif)
 218     (add-to-list 'mime-view-default-showing-Content-Type-list
 219                  "application/postscript")
 220   )
 221
 222
 223 ;;; @ end
 224 ;;;
 225
 226 (provide 'mime-image)
 227
 228 ;;; mime-image.el ends here