1;;; eudc-bob.el --- Binary Objects Support for EUDC
2
3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Oscar Figueiredo <oscar@cpe.fr>
7;; Maintainer: Pavel Jan�k <Pavel@Janik.cz>
8;; Keywords: comm
9
10;; This file is part of GNU Emacs.
11
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)
15;; any later version.
16
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.
21
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.
26
27;;; Commentary:
28
29;;; Usage:
30;;    See the corresponding info file
31
32;;; Code:
33
34(require 'eudc)
35
36(defvar eudc-bob-generic-keymap nil
37  "Keymap for multimedia objects.")
38
39(defvar eudc-bob-image-keymap nil
40  "Keymap for inline images.")
41
42(defvar eudc-bob-sound-keymap nil
43  "Keymap for inline sounds.")
44
45(defvar eudc-bob-url-keymap nil
46  "Keymap for inline urls.")
47
48(defvar eudc-bob-mail-keymap nil
49  "Keymap for inline e-mail addresses.")
50
51(defconst eudc-bob-generic-menu
52  '("EUDC Binary Object Menu"
53    ["---" nil nil]
54    ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
55    ["Save object" eudc-bob-save-object t]))
56
57(defconst eudc-bob-image-menu
58  `("EUDC Image Menu"
59    ["---" nil nil]
60    ["Toggle inline display" eudc-bob-toggle-inline-display
61     (eudc-bob-can-display-inline-images)]
62    ,@(cdr (cdr eudc-bob-generic-menu))))
63
64(defconst eudc-bob-sound-menu
65  `("EUDC Sound Menu"
66    ["---" nil nil]
67    ["Play sound" eudc-bob-play-sound-at-point
68     (fboundp 'play-sound)]
69    ,@(cdr (cdr eudc-bob-generic-menu))))
70
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)))))
77
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))))
82	overlay value
83	(notfound t))
84    (while (and notfound
85		(setq overlay (car overlays)))
86      (if (setq value (overlay-get overlay prop))
87	  (setq notfound nil))
88      (setq overlays (cdr overlays)))
89    value))
90
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))))
98
99(defun eudc-bob-make-button (label keymap &optional menu plist)
100  "Create a button with LABEL.
101Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
102LABEL."
103  (let (overlay
104	(p (point))
105	prop val)
106    (insert label)
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)
113    (while plist
114      (setq prop (car plist)
115	    plist (cdr plist)
116	    val (car plist)
117	    plist (cdr plist))
118      (overlay-put overlay prop val))))
119
120(defun eudc-bob-display-jpeg (data inline)
121  "Display the JPEG DATA at point.
122If INLINE is non-nil, try to inline the image otherwise simply
123display a button."
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
130				 eudc-bob-image-menu
131				 (list 'glyph glyph
132				       'end-glyph (if inline glyph)
133				       'duplicable t
134				       'invisible inline
135				       'start-open t
136				       'end-open t
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
145				 eudc-bob-image-menu
146				 props)))))
147
148(defun eudc-bob-toggle-inline-display ()
149  "Toggle inline display of an image."
150  (interactive)
151  (when (eudc-bob-can-display-inline-images)
152    (cond (eudc-xemacs-p
153	   (let ((overlays (append (overlays-at (1- (point)))
154				   (overlays-at (point))))
155		 overlay glyph)
156	     (setq overlay (car overlays))
157	     (while (and overlay
158			 (not (setq glyph (overlay-get overlay 'glyph))))
159	       (setq overlays (cdr overlays))
160	       (setq overlay (car overlays)))
161	     (if overlay
162		 (if (overlay-get overlay 'end-glyph)
163		     (progn
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)))))
168	  (t
169	   (let* ((overlays (append (overlays-at (1- (point)))
170				    (overlays-at (point))))
171		  image)
172
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))
177		     (setq image prop)
178		   (setq overlays (cdr overlays)))))
179
180	     ;; Toggle that overlay's image display.
181	     (when overlays
182	       (let ((overlay (car overlays)))
183		 (overlay-put overlay 'display
184			      (if (overlay-get overlay 'display)
185				  nil image)))))))))
186
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
191			eudc-bob-sound-menu
192			(list 'duplicable t
193			      'start-open t
194			      'end-open t
195			      'object-data data)))
196
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
202			(list 'duplicable t
203			      'start-open t
204			      'end-open t
205			      'object-data data)))
206
207(defun eudc-bob-play-sound-at-point ()
208  "Play the sound data contained in the button at point."
209  (interactive)
210  (let (sound)
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)))))
216
217(defun eudc-bob-play-sound-at-mouse (event)
218  "Play the sound data contained in the button where EVENT occurred."
219  (interactive "e")
220  (save-excursion
221    (eudc-jump-to-event event)
222    (eudc-bob-play-sound-at-point)))
223
224(defun eudc-bob-save-object ()
225  "Save the object data of the button at point."
226  (interactive)
227  (let ((data (eudc-bob-get-overlay-prop 'object-data))
228	(buffer (generate-new-buffer "*eudc-tmp*")))
229    (save-excursion
230      (if (fboundp 'set-buffer-file-coding-system)
231	  (set-buffer-file-coding-system 'binary))
232      (set-buffer buffer)
233      (set-buffer-multibyte nil)
234      (insert data)
235      (save-buffer))
236    (kill-buffer buffer)))
237
238(defun eudc-bob-pipe-object-to-external-program ()
239  "Pipe the object data of the button at point to an external program."
240  (interactive)
241  (let ((data (eudc-bob-get-overlay-prop 'object-data))
242	(buffer (generate-new-buffer "*eudc-tmp*"))
243	program
244	viewer)
245    (condition-case nil
246	(save-excursion
247	  (if (fboundp 'set-buffer-file-coding-system)
248	      (set-buffer-file-coding-system 'binary))
249	  (set-buffer buffer)
250	  (insert data)
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)
254				   (car (cdr viewer))
255				   (cdr (cdr viewer)))
256	    (call-process-region (point-min) (point-max) program)))
257      (t
258       (kill-buffer buffer)))))
259
260(defun eudc-bob-menu ()
261  "Retrieve the menu attached to a binary object."
262  (eudc-bob-get-overlay-prop 'menu))
263
264(defun eudc-bob-popup-menu (event)
265  "Pop-up a menu of EUDC multimedia commands."
266  (interactive "@e")
267  (run-hooks 'activate-menubar-hook)
268  (eudc-jump-to-event event)
269  (if eudc-xemacs-p
270      (progn
271	(run-hooks 'activate-popup-menu-hook)
272	(popup-menu (eudc-bob-menu)))
273    (let ((result (x-popup-menu t (eudc-bob-menu)))
274	  command)
275      (if result
276	  (progn
277	    (setq command (lookup-key (eudc-bob-menu)
278				      (apply 'vector result)))
279	    (command-execute command))))))
280
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
286			    [button3]
287			  [down-mouse-3]) 'eudc-bob-popup-menu)
288	map))
289
290(setq eudc-bob-image-keymap
291      (let ((map (make-sparse-keymap)))
292	(define-key map "t" 'eudc-bob-toggle-inline-display)
293	map))
294
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
299			    [button2]
300			  [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
301	map))
302
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
307			    [button2]
308			  [down-mouse-2]) 'browse-url-at-mouse)
309	map))
310
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
315			    [button2]
316			  [down-mouse-2]) 'goto-address-at-mouse)
317	map))
318
319(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
320(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
321
322(if eudc-emacs-p
323    (progn
324      (easy-menu-define eudc-bob-generic-menu
325			eudc-bob-generic-keymap
326			""
327			eudc-bob-generic-menu)
328      (easy-menu-define eudc-bob-image-menu
329			eudc-bob-image-keymap
330			""
331			eudc-bob-image-menu)
332      (easy-menu-define eudc-bob-sound-menu
333			eudc-bob-sound-keymap
334			""
335			eudc-bob-sound-menu)))
336
337;;;###autoload
338(defun eudc-display-generic-binary (data)
339  "Display a button for unidentified binary DATA."
340  (eudc-bob-display-generic-binary data))
341
342;;;###autoload
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))
347
348;;;###autoload
349(defun eudc-display-mail (mail)
350  "Display e-mail address and make it clickable."
351  (require 'goto-addr)
352  (eudc-bob-make-button mail eudc-bob-mail-keymap))
353
354;;;###autoload
355(defun eudc-display-sound (data)
356  "Display a button to play the sound DATA."
357  (eudc-bob-display-audio data))
358
359;;;###autoload
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)))
363
364;;;###autoload
365(defun eudc-display-jpeg-as-button (data)
366  "Display a button for the JPEG DATA."
367  (eudc-bob-display-jpeg data nil))
368
369;;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3
370;;; eudc-bob.el ends here
371