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.
29 ;; See the corresponding info file
35 (defvar eudc-bob-generic-keymap nil
36 "Keymap for multimedia objects.")
38 (defvar eudc-bob-image-keymap nil
39 "Keymap for inline images.")
41 (defvar eudc-bob-sound-keymap nil
42 "Keymap for inline sounds.")
44 (defvar eudc-bob-url-keymap nil
45 "Keymap for inline images.")
47 (defconst eudc-bob-generic-menu
48 '("EUDC Binary Object Menu"
50 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
51 ["Save object" eudc-bob-save-object t]))
53 (defconst eudc-bob-image-menu
56 ["Toggle inline display" eudc-bob-toggle-inline-display
57 (eudc-bob-can-display-inline-images)]
58 ,@(cdr (cdr eudc-bob-generic-menu))))
60 (defconst eudc-bob-sound-menu
63 ["Play sound" eudc-bob-play-sound-at-point
64 (fboundp 'play-sound)]
65 ,@(cdr (cdr eudc-bob-generic-menu))))
67 (defun eudc-jump-to-event (event)
68 "Jump to the window and point where EVENT occurred."
70 (goto-char (event-closest-point event))
71 (set-buffer (window-buffer (posn-window (event-start event))))
72 (goto-char (posn-point (event-start event)))))
74 (defun eudc-bob-get-overlay-prop (prop)
75 "Get property PROP from one of the overlays around."
76 (let ((overlays (append (overlays-at (1- (point)))
77 (overlays-at (point))))
81 (setq overlay (car overlays)))
82 (if (setq value (overlay-get overlay prop))
84 (setq overlays (cdr overlays)))
87 (defun eudc-bob-can-display-inline-images ()
88 "Return non-nil if we can display images inline."
90 (and (memq (console-type) '(x mswindows))
91 (fboundp 'make-glyph))
92 (and (boundp 'display-graphic-p)
93 (display-graphic-p))))
95 (defun eudc-bob-make-button (label keymap &optional menu plist)
96 "Create a button with LABEL.
97 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
103 (put-text-property p (point) 'face 'bold)
104 (setq overlay (make-overlay p (point)))
105 (overlay-put overlay 'mouse-face 'highlight)
106 (overlay-put overlay 'keymap keymap)
107 (overlay-put overlay 'local-map keymap)
108 (overlay-put overlay 'menu menu)
110 (setq prop (car plist)
114 (overlay-put overlay prop val))))
116 (defun eudc-bob-display-jpeg (data inline)
117 "Display the JPEG DATA at point.
118 If INLINE is non-nil, try to inline the image otherwise simply
121 (let ((glyph (if (eudc-bob-can-display-inline-images)
122 (make-glyph (list (vector 'jpeg :data data)
123 [string :data "[JPEG Picture]"])))))
124 (eudc-bob-make-button "[JPEG Picture]"
125 eudc-bob-image-keymap
128 'end-glyph (if inline glyph)
133 'object-data data))))
134 ((boundp 'create-image)
135 (let* ((image (create-image data nil t))
136 (props (list 'object-data data 'eudc-image image)))
137 (when (and inline (image-type-available-p 'jpeg))
138 (setq props (nconc (list 'display image) props)))
139 (eudc-bob-make-button "[Picture]"
140 eudc-bob-image-keymap
144 (defun eudc-bob-toggle-inline-display ()
145 "Toggle inline display of an image."
147 (when (eudc-bob-can-display-inline-images)
149 (let ((overlays (append (overlays-at (1- (point)))
150 (overlays-at (point))))
152 (setq overlay (car overlays))
154 (not (setq glyph (overlay-get overlay 'glyph))))
155 (setq overlays (cdr overlays))
156 (setq overlay (car overlays)))
158 (if (overlay-get overlay 'end-glyph)
160 (overlay-put overlay 'end-glyph nil)
161 (overlay-put overlay 'invisible nil))
162 (overlay-put overlay 'end-glyph glyph)
163 (overlay-put overlay 'invisible t)))))
165 (let* ((overlays (append (overlays-at (1- (point)))
166 (overlays-at (point))))
169 ;; Search overlay with an image.
170 (while (and overlays (null image))
171 (let ((prop (overlay-get (car overlays) 'eudc-image)))
172 (if (eq 'image (car-safe prop))
174 (setq overlays (cdr overlays)))))
176 ;; Toggle that overlay's image display.
178 (let ((overlay (car overlays)))
179 (overlay-put overlay 'display
180 (if (overlay-get overlay 'display)
183 (defun eudc-bob-display-audio (data)
184 "Display a button for audio DATA."
185 (eudc-bob-make-button "[Audio Sound]"
186 eudc-bob-sound-keymap
193 (defun eudc-bob-display-generic-binary (data)
194 "Display a button for unidentified binary DATA."
195 (eudc-bob-make-button "[Binary Data]"
196 eudc-bob-generic-keymap
197 eudc-bob-generic-menu
203 (defun eudc-bob-play-sound-at-point ()
204 "Play the sound data contained in the button at point."
207 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
208 (error "No sound data available here")
210 (if (not (and (boundp 'sound-alist)
212 (error "Don't know how to play sound on this Emacs version")
214 (cons (list 'eudc-sound
218 (play-sound 'eudc-sound)
220 (setq sound-alist (cdr sound-alist))))))
222 (unless (fboundp 'play-sound)
223 (error "Playing sounds not supported on this system"))
224 (play-sound (list 'sound :data sound)))))))
227 (defun eudc-bob-play-sound-at-mouse (event)
228 "Play the sound data contained in the button where EVENT occurred."
231 (eudc-jump-to-event event)
232 (eudc-bob-play-sound-at-point)))
235 (defun eudc-bob-save-object ()
236 "Save the object data of the button at point."
238 (let ((data (eudc-bob-get-overlay-prop 'object-data))
239 (buffer (generate-new-buffer "*eudc-tmp*")))
241 (if (fboundp 'set-buffer-file-coding-system)
242 (set-buffer-file-coding-system 'binary))
246 (kill-buffer buffer)))
248 (defun eudc-bob-pipe-object-to-external-program ()
249 "Pipe the object data of the button at point to an external program."
251 (let ((data (eudc-bob-get-overlay-prop 'object-data))
252 (buffer (generate-new-buffer "*eudc-tmp*"))
257 (if (fboundp 'set-buffer-file-coding-system)
258 (set-buffer-file-coding-system 'binary))
261 (setq program (completing-read "Viewer: " eudc-external-viewers))
262 (if (setq viewer (assoc program eudc-external-viewers))
263 (call-process-region (point-min) (point-max)
266 (call-process-region (point-min) (point-max) program)))
268 (kill-buffer buffer)))))
270 (defun eudc-bob-menu ()
271 "Retrieve the menu attached to a binary object."
272 (eudc-bob-get-overlay-prop 'menu))
274 (defun eudc-bob-popup-menu (event)
275 "Pop-up a menu of EUDC multimedia commands."
277 (run-hooks 'activate-menubar-hook)
278 (eudc-jump-to-event event)
281 (run-hooks 'activate-popup-menu-hook)
282 (popup-menu (eudc-bob-menu)))
283 (let ((result (x-popup-menu t (eudc-bob-menu)))
287 (setq command (lookup-key (eudc-bob-menu)
288 (apply 'vector result)))
289 (command-execute command))))))
291 (setq eudc-bob-generic-keymap
292 (let ((map (make-sparse-keymap)))
293 (define-key map "s" 'eudc-bob-save-object)
294 (define-key map (if eudc-xemacs-p
296 [down-mouse-3]) 'eudc-bob-popup-menu)
299 (setq eudc-bob-image-keymap
300 (let ((map (make-sparse-keymap)))
301 (define-key map "t" 'eudc-bob-toggle-inline-display)
304 (setq eudc-bob-sound-keymap
305 (let ((map (make-sparse-keymap)))
306 (define-key map [return] 'eudc-bob-play-sound-at-point)
307 (define-key map (if eudc-xemacs-p
309 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
312 (setq eudc-bob-url-keymap
313 (let ((map (make-sparse-keymap)))
314 (define-key map [return] 'browse-url-at-point)
315 (define-key map (if eudc-xemacs-p
317 [down-mouse-2]) 'browse-url-at-mouse)
320 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
321 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
326 (easy-menu-define eudc-bob-generic-menu
327 eudc-bob-generic-keymap
329 eudc-bob-generic-menu)
330 (easy-menu-define eudc-bob-image-menu
331 eudc-bob-image-keymap
334 (easy-menu-define eudc-bob-sound-menu
335 eudc-bob-sound-keymap
337 eudc-bob-sound-menu)))
340 (defun eudc-display-generic-binary (data)
341 "Display a button for unidentified binary DATA."
342 (eudc-bob-display-generic-binary data))
345 (defun eudc-display-url (url)
346 "Display URL and make it clickable."
347 (require 'browse-url)
348 (eudc-bob-make-button url eudc-bob-url-keymap))
351 (defun eudc-display-sound (data)
352 "Display a button to play the sound DATA."
353 (eudc-bob-display-audio data))
356 (defun eudc-display-jpeg-inline (data)
357 "Display the JPEG DATA inline at point if possible."
358 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
361 (defun eudc-display-jpeg-as-button (data)
362 "Display a button for the JPEG DATA."
363 (eudc-bob-display-jpeg data nil))
365 ;;; eudc-bob.el ends here