~ubuntu-branches/ubuntu/edgy/semi/edgy : revision 1

1

;;; mime-image.el --- mime-view filter to display images

2

3

4

5

6

;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>

7

;; Dan Rich <drich@morpheus.corp.sgi.com>

8

;; Daiki Ueno <ueno@ueda.info.waseda.ac.jp>

9

;; Katsumi Yamaoka <yamaoka@jpl.org>

10

;; Created: 1995/12/15

11

;; Renamed: 1997/2/21 from tm-image.el

12

13

;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news

14

15

;; This file is part of SEMI (Showy Emacs MIME Interfaces).

16

17

;; This program is free software; you can redistribute it and/or

18

;; modify it under the terms of the GNU General Public License as

19

;; published by the Free Software Foundation; either version 2, or (at

20

;; your option) any later version.

21

22

;; This program is distributed in the hope that it will be useful, but

23

;; WITHOUT ANY WARRANTY; without even the implied warranty of

24

;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

25

;; General Public License for more details.

26

27

;; You should have received a copy of the GNU General Public License

28

;; along with GNU XEmacs; see the file COPYING. If not, write to the

29

;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,

30

;; Boston, MA 02111-1307, USA.

31

32

;;; Commentary:

33

;; If you use this program with MULE, please install

34

;; etl8x16-bitmap.bdf font included in tl package.

35

36

;;; Code:

37

38

(eval-when-compile (require 'cl))

39

40

(eval-when-compile (require 'static))

41

42

(require 'mime-view)

43

(require 'alist)

44

(require 'path-util)

45

46

(defsubst mime-image-normalize-xbm-buffer (buffer)

47

(save-excursion

48

(set-buffer buffer)

49

(let ((case-fold-search t) width height xbytes right margin)

50

(goto-char (point-min))

51

(or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)

52

(error "!! Illegal xbm file format in the buffer: %s"

53

(current-buffer)))

54

(setq width (string-to-int (match-string 1))

55

xbytes (/ (+ width 7) 8))

56

(goto-char (point-min))

57

(or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)

58

(error "!! Illegal xbm file format in the buffer: %s"

59

(current-buffer)))

60

(setq height (string-to-int (match-string 1)))

61

(goto-char (point-min))

62

(re-search-forward "0x[0-9a-f][0-9a-f],")

63

(delete-region (point-min) (match-beginning 0))

64

(goto-char (point-min))

65

(while (re-search-forward "[\n\r\t ,;}]" nil t)

66

(replace-match ""))

67

(goto-char (point-min))

68

(while (re-search-forward "0x" nil t)

69

(replace-match "\\x" nil t))

70

(goto-char (point-min))

71

(insert "(" (number-to-string width) " "

72

(number-to-string height) " \"")

73

(goto-char (point-max))

74

(insert "\")")

75

(goto-char (point-min))

76

(read (current-buffer)))))

77

78

(static-if (featurep 'xemacs)

79

(progn

80

(defun mime-image-type-available-p (type)

81

(memq type (image-instantiator-format-list)))

82

83

(defun mime-image-create (file-or-data &optional type data-p &rest props)

84

(when (and data-p (eq type 'xbm))

85

(with-temp-buffer

86

(insert file-or-data)

87

(setq file-or-data

88

(mime-image-normalize-xbm-buffer (current-buffer)))))

89

(let ((glyph

90

(make-glyph

91

(if (and type (mime-image-type-available-p type))

92

(vconcat

93

(list type (if data-p :data :file) file-or-data)

94

props)

95

file-or-data))))

96

(if (nothing-image-instance-p (glyph-image-instance glyph)) nil

97

glyph)))

98

99

(defun mime-image-insert (image &optional string area)

100

(let ((extent (make-extent (point)

101

(progn (and string

102

(insert string))

103

(point)))))

104

(set-extent-property extent 'invisible t)

105

(set-extent-end-glyph extent image))))

106

(condition-case nil

107

(progn

108

(require 'image)

109

(defalias 'mime-image-type-available-p 'image-type-available-p)

110

(defun mime-image-create

111

(file-or-data &optional type data-p &rest props)

112

(if (and data-p (eq type 'xbm))

113

(with-temp-buffer

114

(insert file-or-data)

115

(setq file-or-data

116

(mime-image-normalize-xbm-buffer (current-buffer)))

117

(apply #'create-image (nth 2 file-or-data) type data-p

118

(nconc

119

(list :width (car file-or-data)

120

:height (nth 1 file-or-data))

121

props)))

122

(apply #'create-image file-or-data type data-p props)))

123

(defalias 'mime-image-insert 'insert-image))

124

(error

125

(condition-case nil

126

(progn

127

(require (if (featurep 'mule) 'bitmap ""))

128

(defun mime-image-read-xbm-buffer (buffer)

129

(condition-case nil

130

(mapconcat #'bitmap-compose

131

(append (bitmap-decode-xbm

132

(bitmap-read-xbm-buffer

133

(current-buffer))) nil) "\n")

134

(error nil)))

135

(defun mime-image-insert (image &optional string area)

136

(insert image)))

137

(error

138

(defalias 'mime-image-read-xbm-buffer

139

'mime-image-normalize-xbm-buffer)

140

(defun mime-image-insert (image &optional string area)

141

(save-restriction

142

(narrow-to-region (point)(point))

143

(let ((face (gensym "mii")))

144

(or (facep face) (make-face face))

145

(set-face-stipple face image)

146

(let ((row (make-string (/ (car image) (frame-char-width)) ? ))

147

(height (/ (nth 1 image) (frame-char-height)))

148

(i 0))

149

(while (< i height)

150

(set-text-properties (point) (progn (insert row)(point))

151

(list 'face face))

152

(insert "\n")

153

(setq i (1+ i)))))))))

154

155

(defun mime-image-type-available-p (type)

156

(eq type 'xbm))

157

158

(defun mime-image-create (file-or-data &optional type data-p &rest props)

159

(when (or (null type) (eq type 'xbm))

160

(with-temp-buffer

161

(if data-p

162

(insert file-or-data)

163

(insert-file-contents file-or-data))

164

(mime-image-read-xbm-buffer (current-buffer))))))))

165

166

(defvar mime-image-format-alist

167

'((image jpeg jpeg)

168

(image gif gif)

169

(image tiff tiff)

170

(image x-tiff tiff)

171

(image xbm xbm)

172

(image x-xbm xbm)

173

(image x-xpixmap xpm)

174

(image png png)))

175

176

(dolist (rule mime-image-format-alist)

177

(when (mime-image-type-available-p (nth 2 rule))

178

(ctree-set-calist-strictly

179

'mime-preview-condition

180

(list (cons 'type (car rule))(cons 'subtype (nth 1 rule))

181

'(body . visible)

182

(cons 'body-presentation-method #'mime-display-image)

183

(cons 'image-format (nth 2 rule))))))

184

185

186

;;; @ content filter for images

187

;;;

188

;; (for XEmacs 19.12 or later)

189

190

(defun mime-display-image (entity situation)

191

(message "Decoding image...")

192

(condition-case err

193

(let ((format (cdr (assq 'image-format situation)))

194

image)

195

(setq image

196

(mime-image-create (mime-entity-content entity)

197

format 'data))

198

(if (null image)

199

(message "Invalid glyph!")

200

(save-excursion

201

(mime-image-insert image)

202

(insert "\n")

203

(message "Decoding image...done"))))

204

(error nil err)))

205

206

207

;;; @ end

208

;;;

209

210

(provide 'mime-image)

211

212

;;; mime-image.el ends here