1 ;;; eudc-bob.el --- Binary Objects Support for EUDC
3 ;; Copyright (C) 1999 Free Software Foundation, Inc.
5 ;; Author: Oscar Figueiredo <oscar@xemacs.org>
6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
8 ;; Version: $Revision: 1.4 $
11 ;; This file is part of XEmacs
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to
25 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
31 ;; See the corresponding info file
37 (defvar eudc-bob-generic-keymap nil
38 "Keymap for multimedia objects.")
40 (defvar eudc-bob-image-keymap nil
41 "Keymap for inline images.")
43 (defvar eudc-bob-sound-keymap nil
44 "Keymap for inline sounds.")
46 (defvar eudc-bob-url-keymap nil
47 "Keymap for inline urls.")
49 (defconst eudc-bob-generic-menu
50 '("EUDC Binary Object Menu"
52 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
53 ["Save object" eudc-bob-save-object t]))
55 (defconst eudc-bob-image-menu
58 ["Toggle inline display" eudc-bob-toggle-inline-display
59 (eudc-bob-can-display-inline-images)]
60 ,@(cdr (cdr eudc-bob-generic-menu))))
62 (defconst eudc-bob-sound-menu
65 ["Play sound" eudc-bob-play-sound-at-point
66 (fboundp 'play-sound)]
67 ,@(cdr (cdr eudc-bob-generic-menu))))
69 (defun eudc-jump-to-event (event)
70 "Jump to the window and point where EVENT occurred."
72 (goto-char (event-closest-point event))
73 (set-buffer (window-buffer (posn-window (event-start event))))
74 (goto-char (posn-point (event-start event)))))
76 (defun eudc-bob-get-overlay-prop (prop)
77 "Get property PROP from one of the overlays around."
78 (let ((overlays (append (overlays-at (1- (point)))
79 (overlays-at (point))))
83 (setq overlay (car overlays)))
84 (if (setq value (overlay-get overlay prop))
86 (setq overlays (cdr overlays)))
89 (defun eudc-bob-can-display-inline-images ()
90 "Return non-nil if we can display images inline."
92 (and (memq (console-type) '(x mswindows))
93 (fboundp 'make-glyph))
94 (and (boundp 'image-types)
95 (not (null images-types)))))
97 (defun eudc-bob-make-button (label keymap &optional menu plist)
98 "Create a button with LABEL.
99 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
105 (put-text-property p (point) 'face 'bold)
106 (setq overlay (make-overlay p (point)))
107 (overlay-put overlay 'mouse-face 'highlight)
108 (overlay-put overlay 'keymap keymap)
109 (overlay-put overlay 'local-map keymap)
110 (overlay-put overlay 'menu menu)
112 (setq prop (car plist)
116 (overlay-put overlay prop val))))
118 (defun eudc-bob-display-jpeg (data inline)
119 "Display the JPEG DATA at point.
120 If INLINE is non-nil, try to inline the image otherwise simply
123 (let ((glyph (if (eudc-bob-can-display-inline-images)
124 (make-glyph (list (vector 'jpeg :data data)
125 [string :data "[JPEG Picture]"])))))
126 (eudc-bob-make-button "[JPEG Picture]"
127 eudc-bob-image-keymap
130 'end-glyph (if inline glyph)
135 'object-data data))))
137 (let* ((image (create-image data nil t))
138 (props (list 'object-data data 'eudc-image image)))
140 (setq props (nconc (list 'display image) props)))
141 (eudc-bob-make-button "[Picture]"
142 eudc-bob-image-keymap
146 (defun eudc-bob-toggle-inline-display ()
147 "Toggle inline display of an image."
149 (when (eudc-bob-can-display-inline-images)
151 (let ((overlays (append (overlays-at (1- (point)))
152 (overlays-at (point))))
154 (setq overlay (car overlays))
156 (not (setq glyph (overlay-get overlay 'glyph))))
157 (setq overlays (cdr overlays))
158 (setq overlay (car overlays)))
160 (if (overlay-get overlay 'end-glyph)
162 (overlay-put overlay 'end-glyph nil)
163 (overlay-put overlay 'invisible nil))
164 (overlay-put overlay 'end-glyph glyph)
165 (overlay-put overlay 'invisible t)))))
167 (let* ((overlays (append (overlays-at (1- (point)))
168 (overlays-at (point))))
171 ;; Search overlay with an image.
172 (while (and overlays (null image))
173 (let ((prop (overlay-get (car overlays) 'eudc-image)))
176 (setq overlays (cdr overlays)))))
178 ;; Toggle that overlay's image display.
180 (let ((overlay (car overlays)))
181 (overlay-put overlay 'display
182 (if (overlay-get overlay 'display)
185 (defun eudc-bob-display-audio (data)
186 "Display a button for audio DATA."
187 (eudc-bob-make-button "[Audio Sound]"
188 eudc-bob-sound-keymap
195 (defun eudc-bob-display-generic-binary (data)
196 "Display a button for unidentified binary DATA."
197 (eudc-bob-make-button "[Binary Data]"
198 eudc-bob-generic-keymap
199 eudc-bob-generic-menu
205 (defun eudc-bob-play-sound-at-point ()
206 "Play the sound data contained in the button at point."
209 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
210 (error "No sound data available here")
212 (if (not (and (boundp 'sound-alist)
214 (error "Don't know how to play sound on this Emacs version")
216 (cons (list 'eudc-sound
220 (play-sound 'eudc-sound)
222 (setq sound-alist (cdr sound-alist))))))
224 (unless (fboundp 'play-sound)
225 (error "Playing sounds not supported on this system"))
226 (play-sound (list 'sound :data sound)))))))
229 (defun eudc-bob-play-sound-at-mouse (event)
230 "Play the sound data contained in the button where EVENT occurred."
233 (eudc-jump-to-event event)
234 (eudc-bob-play-sound-at-point)))
237 (defun eudc-bob-save-object ()
238 "Save the object data of the button at point."
240 (let ((data (eudc-bob-get-overlay-prop 'object-data))
241 (buffer (generate-new-buffer "*eudc-tmp*")))
243 (if (fboundp 'set-buffer-file-coding-system)
244 (set-buffer-file-coding-system 'binary))
248 (kill-buffer buffer)))
250 (defun eudc-bob-pipe-object-to-external-program ()
251 "Pipe the object data of the button at point to an external program."
253 (let ((data (eudc-bob-get-overlay-prop 'object-data))
254 (buffer (generate-new-buffer "*eudc-tmp*"))
259 (if (fboundp 'set-buffer-file-coding-system)
260 (set-buffer-file-coding-system 'binary))
263 (setq program (completing-read "Viewer: " eudc-external-viewers))
264 (if (setq viewer (assoc program eudc-external-viewers))
265 (call-process-region (point-min) (point-max)
268 (call-process-region (point-min) (point-max) program)))
270 (kill-buffer buffer)))))
272 (defun eudc-bob-menu ()
273 "Retrieve the menu attached to a binary object."
274 (eudc-bob-get-overlay-prop 'menu))
276 (defun eudc-bob-popup-menu (event)
277 "Pop-up a menu of EUDC multimedia commands."
279 (run-hooks 'activate-menubar-hook)
280 (eudc-jump-to-event event)
283 (run-hooks 'activate-popup-menu-hook)
284 (popup-menu (eudc-bob-menu)))
285 (let ((result (x-popup-menu t (eudc-bob-menu)))
289 (setq command (lookup-key (eudc-bob-menu)
290 (apply 'vector result)))
291 (command-execute command))))))
293 (setq eudc-bob-generic-keymap
294 (let ((map (make-sparse-keymap)))
295 (define-key map "s" 'eudc-bob-save-object)
296 (define-key map (if eudc-xemacs-p
298 [down-mouse-3]) 'eudc-bob-popup-menu)
301 (setq eudc-bob-image-keymap
302 (let ((map (make-sparse-keymap)))
303 (define-key map "t" 'eudc-bob-toggle-inline-display)
306 (setq eudc-bob-sound-keymap
307 (let ((map (make-sparse-keymap)))
308 (define-key map [return] 'eudc-bob-play-sound-at-point)
309 (define-key map (if eudc-xemacs-p
311 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
314 (setq eudc-bob-url-keymap
315 (let ((map (make-sparse-keymap)))
316 (define-key map [return] 'browse-url-at-point)
317 (define-key map (if eudc-xemacs-p
319 [down-mouse-2]) 'browse-url-at-mouse)
322 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
323 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
328 (easy-menu-define eudc-bob-generic-menu
329 eudc-bob-generic-keymap
331 eudc-bob-generic-menu)
332 (easy-menu-define eudc-bob-image-menu
333 eudc-bob-image-keymap
336 (easy-menu-define eudc-bob-sound-menu
337 eudc-bob-sound-keymap
339 eudc-bob-sound-menu)))
342 (defun eudc-display-generic-binary (data)
343 "Display a button for unidentified binary DATA."
344 (eudc-bob-display-generic-binary data))
347 (defun eudc-display-url (url)
348 "Display URL and make it clickable."
349 (require 'browse-url)
350 (eudc-bob-make-button url eudc-bob-url-keymap))
353 (defun eudc-display-sound (data)
354 "Display a button to play the sound DATA."
355 (eudc-bob-display-audio data))
358 (defun eudc-display-jpeg-inline (data)
359 "Display the JPEG DATA inline at point if possible."
360 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
363 (defun eudc-display-jpeg-as-button (data)
364 "Display a button for the JPEG DATA."
365 (eudc-bob-display-jpeg data nil))
367 ;;; eudc-bob.el ends here