1 ;;; eudc-bob.el --- Binary Objects Support for EUDC
3 ;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
7 ;; Maintainer: Pavel JanÃk <Pavel@Janik.cz>
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
30 ;; See the corresponding info file
36 (defvar eudc-bob-generic-keymap nil
37 "Keymap for multimedia objects.")
39 (defvar eudc-bob-image-keymap nil
40 "Keymap for inline images.")
42 (defvar eudc-bob-sound-keymap nil
43 "Keymap for inline sounds.")
45 (defvar eudc-bob-url-keymap nil
46 "Keymap for inline urls.")
48 (defvar eudc-bob-mail-keymap nil
49 "Keymap for inline e-mail addresses.")
51 (defconst eudc-bob-generic-menu
52 '("EUDC Binary Object Menu"
54 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
55 ["Save object" eudc-bob-save-object t]))
57 (defconst eudc-bob-image-menu
60 ["Toggle inline display" eudc-bob-toggle-inline-display
61 (eudc-bob-can-display-inline-images)]
62 ,@(cdr (cdr eudc-bob-generic-menu))))
64 (defconst eudc-bob-sound-menu
67 ["Play sound" eudc-bob-play-sound-at-point
68 (fboundp 'play-sound)]
69 ,@(cdr (cdr eudc-bob-generic-menu))))
71 (defun eudc-jump-to-event (event)
72 "Jump to the window and point where EVENT occurred."
73 (if (fboundp 'event-closest-point)
74 (goto-char (event-closest-point event))
75 (set-buffer (window-buffer (posn-window (event-start event))))
76 (goto-char (posn-point (event-start event)))))
78 (defun eudc-bob-get-overlay-prop (prop)
79 "Get property PROP from one of the overlays around."
80 (let ((overlays (append (overlays-at (1- (point)))
81 (overlays-at (point))))
85 (setq overlay (car overlays)))
86 (if (setq value (overlay-get overlay prop))
88 (setq overlays (cdr overlays)))
91 (defun eudc-bob-can-display-inline-images ()
92 "Return non-nil if we can display images inline."
93 (if (fboundp 'console-type)
94 (and (memq (console-type) '(x mswindows))
95 (fboundp 'make-glyph))
96 (and (fboundp 'display-graphic-p)
97 (display-graphic-p))))
99 (defun eudc-bob-make-button (label keymap &optional menu plist)
100 "Create a button with LABEL.
101 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
107 (put-text-property p (point) 'face 'bold)
108 (setq overlay (make-overlay p (point)))
109 (overlay-put overlay 'mouse-face 'highlight)
110 (overlay-put overlay 'keymap keymap)
111 (overlay-put overlay 'local-map keymap)
112 (overlay-put overlay 'menu menu)
114 (setq prop (car plist)
118 (overlay-put overlay prop val))))
120 (defun eudc-bob-display-jpeg (data inline)
121 "Display the JPEG DATA at point.
122 If INLINE is non-nil, try to inline the image otherwise simply
124 (cond ((fboundp 'make-glyph)
125 (let ((glyph (if (eudc-bob-can-display-inline-images)
126 (make-glyph (list (vector 'jpeg :data data)
127 [string :data "[JPEG Picture]"])))))
128 (eudc-bob-make-button "[JPEG Picture]"
129 eudc-bob-image-keymap
132 'end-glyph (if inline glyph)
137 'object-data data))))
138 ((fboundp 'create-image)
139 (let* ((image (create-image data nil t))
140 (props (list 'object-data data 'eudc-image image)))
141 (when (and inline (image-type-available-p 'jpeg))
142 (setq props (nconc (list 'display image) props)))
143 (eudc-bob-make-button "[Picture]"
144 eudc-bob-image-keymap
148 (defun eudc-bob-toggle-inline-display ()
149 "Toggle inline display of an image."
151 (when (eudc-bob-can-display-inline-images)
153 (let ((overlays (append (overlays-at (1- (point)))
154 (overlays-at (point))))
156 (setq overlay (car overlays))
158 (not (setq glyph (overlay-get overlay 'glyph))))
159 (setq overlays (cdr overlays))
160 (setq overlay (car overlays)))
162 (if (overlay-get overlay 'end-glyph)
164 (overlay-put overlay 'end-glyph nil)
165 (overlay-put overlay 'invisible nil))
166 (overlay-put overlay 'end-glyph glyph)
167 (overlay-put overlay 'invisible t)))))
169 (let* ((overlays (append (overlays-at (1- (point)))
170 (overlays-at (point))))
173 ;; Search overlay with an image.
174 (while (and overlays (null image))
175 (let ((prop (overlay-get (car overlays) 'eudc-image)))
176 (if (eq 'image (car-safe prop))
178 (setq overlays (cdr overlays)))))
180 ;; Toggle that overlay's image display.
182 (let ((overlay (car overlays)))
183 (overlay-put overlay 'display
184 (if (overlay-get overlay 'display)
187 (defun eudc-bob-display-audio (data)
188 "Display a button for audio DATA."
189 (eudc-bob-make-button "[Audio Sound]"
190 eudc-bob-sound-keymap
197 (defun eudc-bob-display-generic-binary (data)
198 "Display a button for unidentified binary DATA."
199 (eudc-bob-make-button "[Binary Data]"
200 eudc-bob-generic-keymap
201 eudc-bob-generic-menu
207 (defun eudc-bob-play-sound-at-point ()
208 "Play the sound data contained in the button at point."
211 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
212 (error "No sound data available here")
213 (unless (fboundp 'play-sound)
214 (error "Playing sounds not supported on this system"))
215 (play-sound (list 'sound :data sound)))))
217 (defun eudc-bob-play-sound-at-mouse (event)
218 "Play the sound data contained in the button where EVENT occurred."
221 (eudc-jump-to-event event)
222 (eudc-bob-play-sound-at-point)))
224 (defun eudc-bob-save-object ()
225 "Save the object data of the button at point."
227 (let ((data (eudc-bob-get-overlay-prop 'object-data))
228 (buffer (generate-new-buffer "*eudc-tmp*")))
230 (if (fboundp 'set-buffer-file-coding-system)
231 (set-buffer-file-coding-system 'binary))
233 (set-buffer-multibyte nil)
236 (kill-buffer buffer)))
238 (defun eudc-bob-pipe-object-to-external-program ()
239 "Pipe the object data of the button at point to an external program."
241 (let ((data (eudc-bob-get-overlay-prop 'object-data))
242 (buffer (generate-new-buffer "*eudc-tmp*"))
247 (if (fboundp 'set-buffer-file-coding-system)
248 (set-buffer-file-coding-system 'binary))
251 (setq program (completing-read "Viewer: " eudc-external-viewers))
252 (if (setq viewer (assoc program eudc-external-viewers))
253 (call-process-region (point-min) (point-max)
256 (call-process-region (point-min) (point-max) program)))
258 (kill-buffer buffer)))))
260 (defun eudc-bob-menu ()
261 "Retrieve the menu attached to a binary object."
262 (eudc-bob-get-overlay-prop 'menu))
264 (defun eudc-bob-popup-menu (event)
265 "Pop-up a menu of EUDC multimedia commands."
267 (run-hooks 'activate-menubar-hook)
268 (eudc-jump-to-event event)
271 (run-hooks 'activate-popup-menu-hook)
272 (popup-menu (eudc-bob-menu)))
273 (let ((result (x-popup-menu t (eudc-bob-menu)))
277 (setq command (lookup-key (eudc-bob-menu)
278 (apply 'vector result)))
279 (command-execute command))))))
281 (setq eudc-bob-generic-keymap
282 (let ((map (make-sparse-keymap)))
283 (define-key map "s" 'eudc-bob-save-object)
284 (define-key map "!" 'eudc-bob-pipe-object-to-external-program)
285 (define-key map (if eudc-xemacs-p
287 [down-mouse-3]) 'eudc-bob-popup-menu)
290 (setq eudc-bob-image-keymap
291 (let ((map (make-sparse-keymap)))
292 (define-key map "t" 'eudc-bob-toggle-inline-display)
295 (setq eudc-bob-sound-keymap
296 (let ((map (make-sparse-keymap)))
297 (define-key map [return] 'eudc-bob-play-sound-at-point)
298 (define-key map (if eudc-xemacs-p
300 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
303 (setq eudc-bob-url-keymap
304 (let ((map (make-sparse-keymap)))
305 (define-key map [return] 'browse-url-at-point)
306 (define-key map (if eudc-xemacs-p
308 [down-mouse-2]) 'browse-url-at-mouse)
311 (setq eudc-bob-mail-keymap
312 (let ((map (make-sparse-keymap)))
313 (define-key map [return] 'goto-address-at-point)
314 (define-key map (if eudc-xemacs-p
316 [down-mouse-2]) 'goto-address-at-mouse)
319 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
320 (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-mail (mail)
350 "Display e-mail address and make it clickable."
352 (eudc-bob-make-button mail eudc-bob-mail-keymap))
355 (defun eudc-display-sound (data)
356 "Display a button to play the sound DATA."
357 (eudc-bob-display-audio data))
360 (defun eudc-display-jpeg-inline (data)
361 "Display the JPEG DATA inline at point if possible."
362 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
365 (defun eudc-display-jpeg-as-button (data)
366 "Display a button for the JPEG DATA."
367 (eudc-bob-display-jpeg data nil))
369 ;;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3
370 ;;; eudc-bob.el ends here