1 ;;; eudc-bob.el --- Binary Objects Support for EUDC
3 ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
5 ;; Author: Oscar Figueiredo <oscar@xemacs.org>
6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
27 ;; See the corresponding info file
33 (defvar eudc-bob-generic-keymap nil
34 "Keymap for multimedia objects.")
36 (defvar eudc-bob-image-keymap nil
37 "Keymap for inline images.")
39 (defvar eudc-bob-sound-keymap nil
40 "Keymap for inline sounds.")
42 (defvar eudc-bob-url-keymap nil
43 "Keymap for inline images.")
45 (defconst eudc-bob-generic-menu
46 '("EUDC Binary Object Menu"
48 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t
]
49 ["Save object" eudc-bob-save-object t
]))
51 (defconst eudc-bob-image-menu
54 ["Toggle inline display" eudc-bob-toggle-inline-display
55 (eudc-bob-can-display-inline-images)]
56 ,@(cdr (cdr eudc-bob-generic-menu
))))
58 (defconst eudc-bob-sound-menu
61 ["Play sound" eudc-bob-play-sound-at-point
62 (fboundp 'play-sound
)]
63 ,@(cdr (cdr eudc-bob-generic-menu
))))
65 (defun eudc-jump-to-event (event)
66 "Jump to the window and point where EVENT occurred."
68 (goto-char (event-closest-point event
))
69 (set-buffer (window-buffer (posn-window (event-start event
))))
70 (goto-char (posn-point (event-start event
)))))
72 (defun eudc-bob-get-overlay-prop (prop)
73 "Get property PROP from one of the overlays around."
74 (let ((overlays (append (overlays-at (1- (point)))
75 (overlays-at (point))))
79 (setq overlay
(car overlays
)))
80 (if (setq value
(overlay-get overlay prop
))
82 (setq overlays
(cdr overlays
)))
85 (defun eudc-bob-can-display-inline-images ()
86 "Return non-nil if we can display images inline."
88 (and (memq (console-type) '(x mswindows
))
89 (fboundp 'make-glyph
))
90 (and (boundp 'display-graphic-p
)
91 (display-graphic-p))))
93 (defun eudc-bob-make-button (label keymap
&optional menu plist
)
94 "Create a button with LABEL.
95 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
101 (put-text-property p
(point) 'face
'bold
)
102 (setq overlay
(make-overlay p
(point)))
103 (overlay-put overlay
'mouse-face
'highlight
)
104 (overlay-put overlay
'keymap keymap
)
105 (overlay-put overlay
'local-map keymap
)
106 (overlay-put overlay
'menu menu
)
108 (setq prop
(car plist
)
112 (overlay-put overlay prop val
))))
114 (defun eudc-bob-display-jpeg (data inline
)
115 "Display the JPEG DATA at point.
116 If INLINE is non-nil, try to inline the image otherwise simply
119 (let ((glyph (if (eudc-bob-can-display-inline-images)
120 (make-glyph (list (vector 'jpeg
:data data
)
121 [string
:data
"[JPEG Picture]"])))))
122 (eudc-bob-make-button "[JPEG Picture]"
123 eudc-bob-image-keymap
126 'end-glyph
(if inline glyph
)
131 'object-data data
))))
132 ((boundp 'create-image
)
133 (let* ((image (create-image data nil t
))
134 (props (list 'object-data data
'eudc-image image
)))
135 (when (and inline
(image-type-available-p 'jpeg
))
136 (setq props
(nconc (list 'display image
) props
)))
137 (eudc-bob-make-button "[Picture]"
138 eudc-bob-image-keymap
142 (defun eudc-bob-toggle-inline-display ()
143 "Toggle inline display of an image."
145 (when (eudc-bob-can-display-inline-images)
147 (let ((overlays (append (overlays-at (1- (point)))
148 (overlays-at (point))))
150 (setq overlay
(car overlays
))
152 (not (setq glyph
(overlay-get overlay
'glyph
))))
153 (setq overlays
(cdr overlays
))
154 (setq overlay
(car overlays
)))
156 (if (overlay-get overlay
'end-glyph
)
158 (overlay-put overlay
'end-glyph nil
)
159 (overlay-put overlay
'invisible nil
))
160 (overlay-put overlay
'end-glyph glyph
)
161 (overlay-put overlay
'invisible t
)))))
163 (let* ((overlays (append (overlays-at (1- (point)))
164 (overlays-at (point))))
167 ;; Search overlay with an image.
168 (while (and overlays
(null image
))
169 (let ((prop (overlay-get (car overlays
) 'eudc-image
)))
170 (if (eq 'image
(car-safe prop
))
172 (setq overlays
(cdr overlays
)))))
174 ;; Toggle that overlay's image display.
176 (let ((overlay (car overlays
)))
177 (overlay-put overlay
'display
178 (if (overlay-get overlay
'display
)
181 (defun eudc-bob-display-audio (data)
182 "Display a button for audio DATA."
183 (eudc-bob-make-button "[Audio Sound]"
184 eudc-bob-sound-keymap
191 (defun eudc-bob-display-generic-binary (data)
192 "Display a button for unidentified binary DATA."
193 (eudc-bob-make-button "[Binary Data]"
194 eudc-bob-generic-keymap
195 eudc-bob-generic-menu
201 (defun eudc-bob-play-sound-at-point ()
202 "Play the sound data contained in the button at point."
205 (if (null (setq sound
(eudc-bob-get-overlay-prop 'object-data
)))
206 (error "No sound data available here")
208 (if (not (and (boundp 'sound-alist
)
210 (error "Don't know how to play sound on this Emacs version")
212 (cons (list 'eudc-sound
216 (play-sound 'eudc-sound
)
218 (setq sound-alist
(cdr sound-alist
))))))
220 (unless (fboundp 'play-sound
)
221 (error "Playing sounds not supported on this system"))
222 (play-sound (list 'sound
:data sound
)))))))
225 (defun eudc-bob-play-sound-at-mouse (event)
226 "Play the sound data contained in the button where EVENT occurred."
229 (eudc-jump-to-event event
)
230 (eudc-bob-play-sound-at-point)))
233 (defun eudc-bob-save-object ()
234 "Save the object data of the button at point."
236 (let ((data (eudc-bob-get-overlay-prop 'object-data
))
237 (buffer (generate-new-buffer "*eudc-tmp*")))
239 (if (fboundp 'set-buffer-file-coding-system
)
240 (set-buffer-file-coding-system 'binary
))
244 (kill-buffer buffer
)))
246 (defun eudc-bob-pipe-object-to-external-program ()
247 "Pipe the object data of the button at point to an external program."
249 (let ((data (eudc-bob-get-overlay-prop 'object-data
))
250 (buffer (generate-new-buffer "*eudc-tmp*"))
255 (if (fboundp 'set-buffer-file-coding-system
)
256 (set-buffer-file-coding-system 'binary
))
259 (setq program
(completing-read "Viewer: " eudc-external-viewers
))
260 (if (setq viewer
(assoc program eudc-external-viewers
))
261 (call-process-region (point-min) (point-max)
264 (call-process-region (point-min) (point-max) program
)))
266 (kill-buffer buffer
)))))
268 (defun eudc-bob-menu ()
269 "Retrieve the menu attached to a binary object."
270 (eudc-bob-get-overlay-prop 'menu
))
272 (defun eudc-bob-popup-menu (event)
273 "Pop-up a menu of EUDC multimedia commands."
275 (run-hooks 'activate-menubar-hook
)
276 (eudc-jump-to-event event
)
279 (run-hooks 'activate-popup-menu-hook
)
280 (popup-menu (eudc-bob-menu)))
281 (let ((result (x-popup-menu t
(eudc-bob-menu)))
285 (setq command
(lookup-key (eudc-bob-menu)
286 (apply 'vector result
)))
287 (command-execute command
))))))
289 (setq eudc-bob-generic-keymap
290 (let ((map (make-sparse-keymap)))
291 (define-key map
"s" 'eudc-bob-save-object
)
292 (define-key map
(if eudc-xemacs-p
294 [down-mouse-3]) 'eudc-bob-popup-menu)
297 (setq eudc-bob-image-keymap
298 (let ((map (make-sparse-keymap)))
299 (define-key map "t" 'eudc-bob-toggle-inline-display)
302 (setq eudc-bob-sound-keymap
303 (let ((map (make-sparse-keymap)))
304 (define-key map [return] 'eudc-bob-play-sound-at-point)
305 (define-key map (if eudc-xemacs-p
307 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
310 (setq eudc-bob-url-keymap
311 (let ((map (make-sparse-keymap)))
312 (define-key map [return] 'browse-url-at-point)
313 (define-key map (if eudc-xemacs-p
315 [down-mouse-2]) 'browse-url-at-mouse)
318 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
319 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
324 (easy-menu-define eudc-bob-generic-menu
325 eudc-bob-generic-keymap
327 eudc-bob-generic-menu)
328 (easy-menu-define eudc-bob-image-menu
329 eudc-bob-image-keymap
332 (easy-menu-define eudc-bob-sound-menu
333 eudc-bob-sound-keymap
335 eudc-bob-sound-menu)))
338 (defun eudc-display-generic-binary (data)
339 "Display a button for unidentified binary DATA."
340 (eudc-bob-display-generic-binary data))
343 (defun eudc-display-url (url)
344 "Display URL and make it clickable."
345 (require 'browse-url)
346 (eudc-bob-make-button url eudc-bob-url-keymap))
349 (defun eudc-display-sound (data)
350 "Display a button to play the sound DATA."
351 (eudc-bob-display-audio data))
354 (defun eudc-display-jpeg-inline (data)
355 "Display the JPEG DATA inline at point if possible."
356 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
359 (defun eudc-display-jpeg-as-button (data)
360 "Display a button for the JPEG DATA."
361 (eudc-bob-display-jpeg data nil))
363 ;;; eudc-bob.el ends here