1 ;;; eudc-bob.el --- Binary Objects Support for EUDC -*- coding: utf-8 -*-
3 ;; Copyright (C) 1999-2013 Free Software Foundation, Inc.
5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
6 ;; 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 3 of the License, or
15 ;; (at your option) any later version.
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. If not, see <http://www.gnu.org/licenses/>.
28 ;; See the corresponding info file
34 (defvar eudc-bob-generic-keymap nil
35 "Keymap for multimedia objects.")
37 (defvar eudc-bob-image-keymap nil
38 "Keymap for inline images.")
40 (defvar eudc-bob-sound-keymap nil
41 "Keymap for inline sounds.")
43 (defvar eudc-bob-url-keymap nil
44 "Keymap for inline urls.")
46 (defvar eudc-bob-mail-keymap nil
47 "Keymap for inline e-mail addresses.")
49 (defvar 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 (defvar 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 (defvar 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."
71 (if (fboundp 'event-closest-point)
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."
91 (if (fboundp 'console-type)
92 (and (memq (console-type) '(x mswindows))
93 (fboundp 'make-glyph))
94 (and (fboundp 'display-graphic-p)
95 (display-graphic-p))))
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
122 (cond ((fboundp 'make-glyph)
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))))
136 ((fboundp 'create-image)
137 (let* ((image (create-image data nil t))
138 (props (list 'object-data data 'eudc-image image)))
139 (when (and inline (image-type-available-p 'jpeg))
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)
150 (cond ((featurep 'xemacs)
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)))
174 (if (eq 'image (car-safe prop))
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")
211 (unless (fboundp 'play-sound)
212 (error "Playing sounds not supported on this system"))
213 (play-sound (list 'sound :data sound)))))
215 (defun eudc-bob-play-sound-at-mouse (event)
216 "Play the sound data contained in the button where EVENT occurred."
219 (eudc-jump-to-event event)
220 (eudc-bob-play-sound-at-point)))
222 (defun eudc-bob-save-object ()
223 "Save the object data of the button at point."
225 (let ((data (eudc-bob-get-overlay-prop 'object-data))
226 (buffer (generate-new-buffer "*eudc-tmp*")))
228 (if (fboundp 'set-buffer-file-coding-system)
229 (set-buffer-file-coding-system 'binary))
231 (set-buffer-multibyte nil)
234 (kill-buffer buffer)))
236 (defun eudc-bob-pipe-object-to-external-program ()
237 "Pipe the object data of the button at point to an external program."
239 (let ((data (eudc-bob-get-overlay-prop 'object-data))
240 (buffer (generate-new-buffer "*eudc-tmp*"))
245 (if (fboundp 'set-buffer-file-coding-system)
246 (set-buffer-file-coding-system 'binary))
249 (setq program (completing-read "Viewer: " eudc-external-viewers))
250 (if (setq viewer (assoc program eudc-external-viewers))
251 (call-process-region (point-min) (point-max)
254 (call-process-region (point-min) (point-max) program)))
256 (kill-buffer buffer)))))
258 (defun eudc-bob-menu ()
259 "Retrieve the menu attached to a binary object."
260 (eudc-bob-get-overlay-prop 'menu))
262 (defun eudc-bob-popup-menu (event)
263 "Pop-up a menu of EUDC multimedia commands."
265 (run-hooks 'activate-menubar-hook)
266 (eudc-jump-to-event event)
267 (if (featurep 'xemacs)
269 (run-hooks 'activate-popup-menu-hook)
270 (popup-menu (eudc-bob-menu)))
271 (let ((result (x-popup-menu t (eudc-bob-menu)))
275 (setq command (lookup-key (eudc-bob-menu)
276 (apply 'vector result)))
277 (command-execute command))))))
279 (setq eudc-bob-generic-keymap
280 (let ((map (make-sparse-keymap)))
281 (define-key map "s" 'eudc-bob-save-object)
282 (define-key map "!" 'eudc-bob-pipe-object-to-external-program)
283 (define-key map (if (featurep 'xemacs)
285 [down-mouse-3]) 'eudc-bob-popup-menu)
288 (setq eudc-bob-image-keymap
289 (let ((map (make-sparse-keymap)))
290 (define-key map "t" 'eudc-bob-toggle-inline-display)
293 (setq eudc-bob-sound-keymap
294 (let ((map (make-sparse-keymap)))
295 (define-key map [return] 'eudc-bob-play-sound-at-point)
296 (define-key map (if (featurep 'xemacs)
298 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
301 (setq eudc-bob-url-keymap
302 (let ((map (make-sparse-keymap)))
303 (define-key map [return] 'browse-url-at-point)
304 (define-key map (if (featurep 'xemacs)
306 [down-mouse-2]) 'browse-url-at-mouse)
309 (setq eudc-bob-mail-keymap
310 (let ((map (make-sparse-keymap)))
311 (define-key map [return] 'goto-address-at-point)
312 (define-key map (if (featurep 'xemacs)
314 [down-mouse-2]) 'goto-address-at-mouse)
317 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
318 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
320 ;; If the first arguments can be nil here, then these 3 can be
321 ;; defconsts once more.
322 (when (not (featurep 'xemacs))
323 (easy-menu-define eudc-bob-generic-menu
324 eudc-bob-generic-keymap
326 eudc-bob-generic-menu)
327 (easy-menu-define eudc-bob-image-menu
328 eudc-bob-image-keymap
331 (easy-menu-define eudc-bob-sound-menu
332 eudc-bob-sound-keymap
334 eudc-bob-sound-menu))
337 (defun eudc-display-generic-binary (data)
338 "Display a button for unidentified binary DATA."
339 (eudc-bob-display-generic-binary data))
342 (defun eudc-display-url (url)
343 "Display URL and make it clickable."
344 (require 'browse-url)
345 (eudc-bob-make-button url eudc-bob-url-keymap))
348 (defun eudc-display-mail (mail)
349 "Display e-mail address and make it clickable."
351 (eudc-bob-make-button mail eudc-bob-mail-keymap))
354 (defun eudc-display-sound (data)
355 "Display a button to play the sound DATA."
356 (eudc-bob-display-audio data))
359 (defun eudc-display-jpeg-inline (data)
360 "Display the JPEG DATA inline at point if possible."
361 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
364 (defun eudc-display-jpeg-as-button (data)
365 "Display a button for the JPEG DATA."
366 (eudc-bob-display-jpeg data nil))
368 ;;; eudc-bob.el ends here