tm 7.43.1.

[elisp/tm.git] / tm-image.el

diff --git a/tm-image.el b/tm-image.el
index 44bf3e4..4772248 100644 (file)
--- a/tm-image.el
+++ b/tm-image.el
@@ -8,7 +8,7 @@
 ;;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;;; Created: 1995/12/15
 ;;; Version:
-;;;    $Id: tm-image.el,v 4.0 1996/01/31 17:15:55 morioka Exp $
+;;;    $Id: tm-image.el,v 4.6 1996/02/13 17:56:43 morioka Exp $
 ;;;
 ;;; Keywords: mail, news, MIME, multimedia, image, picture
 ;;;
@@ -63,14 +63,25 @@
           "image/x-tiff" "image/x-pic" "image/x-mag" "image/x-xbm"))
 
        (defun bitmap-read-xbm (file)
-        (let ((gl (make-glyph file)))
+        (let (gl)
+          (while (progn
+                   (setq gl (make-glyph file))
+                   (eq (image-instance-type (glyph-image-instance gl))
+                       'text)
+                   ))
           (make-annotation gl (point) 'text)
           ))
+       
+       (defvar mime-preview/x-face-function
+        (function mime-preview/x-face-function-for-xemacs))
        )
       ((boundp 'MULE)
        (require 'bitmap)
        
        (defvar tm-image/inline-image-types '("image/x-mag" "image/x-xbm"))
+       
+       (defvar mime-preview/x-face-function
+        (function mime-preview/x-face-function-for-mule))
        ))
 
 (defvar mime-viewer/shell-command "/bin/sh")
@@ -85,6 +96,89 @@
     ("image/x-mag"  . "magtoppm < %s | ppmtoxpm > %s")
     ))
 
+(defvar mime-viewer/x-face-to-xbm-command
+  (concat mime-viewer/x-face-to-pbm-command " | pbmtoxbm"))
+
+(add-hook 'mime-viewer/content-header-filter-hook
+         mime-preview/x-face-function)
+
+(defun mime-preview/x-face-function-for-xemacs ()
+  (save-restriction
+    (narrow-to-region (point-min) (re-search-forward "^$" nil t))
+    (goto-char (point-min))
+    (if (re-search-forward "^X-Face:[ \t]*" nil t)
+       (let ((beg (match-end 0))
+             (end (rfc822/field-end))
+             (xbm-file
+              (make-temp-name (expand-file-name "tmxf" mime/tmp-dir))
+              ))
+         (call-process-region
+          beg end "sh" nil 0 nil
+          "-c"
+          (format "%s > %s"
+                  mime-viewer/x-face-to-xbm-command
+                  xbm-file))
+         (while (not (file-exists-p xbm-file)))
+         (delete-region beg end)
+         (bitmap-read-xbm xbm-file)
+         (condition-case nil
+             (delete-file xbm-file)
+           (error nil))
+         ))))
+
+(defun mime-preview/x-face-function-for-mule ()
+  (save-restriction
+    (narrow-to-region (point-min) (re-search-forward "^$" nil t))
+    (goto-char (point-min))
+    (if (re-search-forward "^X-Face:[ \t]*" nil t)
+       (let ((p (match-beginning 0))
+             (beg (match-end 0))
+             (end (rfc822/field-end))
+             (xbm-file
+              (concat
+               (make-temp-name (expand-file-name "tmxf" mime/tmp-dir))
+               ".xbm")
+              ))
+         (if (< end (point-max))
+             (setq end (1+ end))
+           )
+         (while (progn
+                  (call-process-region
+                   beg end "sh" nil 0 nil
+                   "-c"
+                   (format "%s > %s"
+                           mime-viewer/x-face-to-xbm-command
+                           xbm-file))
+                  (not (file-exists-p xbm-file))
+                  ))
+         (save-restriction
+           (narrow-to-region p end)
+           (delete-region p end)
+           (goto-char p)
+           (while (progn
+                    (condition-case nil
+                        (bitmap-read-xbm xbm-file)
+                      (error nil))
+                    (kill-buffer 
+                     (some-element
+                      (function
+                       (lambda (buf)
+                         (string-equal (buffer-file-name buf) xbm-file)
+                         ))
+                      (buffer-list)))
+                    (= (point-min) (point-max))
+                    ))
+           (goto-char p)
+           (insert "X-Face: ")
+           (while (re-search-forward "^." nil t)
+             (goto-char (match-beginning 0))
+             (insert "        ")
+             ))
+         (condition-case nil
+             (delete-file xbm-file)
+           (error nil))
+         ))))
+
 
 ;;; @ content filter for images
 ;;;
@@ -112,8 +206,11 @@
                 )
          (setq gl (make-glyph xbm-file))
          (setq annot (make-annotation gl (point) 'text))
-         (delete-file orig-file)
-         (delete-file xbm-file)
+         (unwind-protect
+             (delete-file orig-file)
+           (condition-case nil
+               (delete-file xbm-file)
+             (error nil)))
          (goto-char (point-max))
          (insert "\n")
          (message "Translation done.")