(locale-charset-language-names):
[bpt/emacs.git] / lisp / net / eudc-bob.el
CommitLineData
7970b229
GM
1;;; eudc-bob.el --- Binary Objects Support for EUDC
2
3;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
4
5;; Author: Oscar Figueiredo <oscar@xemacs.org>
6;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
7;; Keywords: help
8
9;; This file is part of GNU Emacs.
10
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)
14;; any later version.
15
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.
20
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.
25
26;;; Usage:
27;; See the corresponding info file
28
29;;; Code:
30
31(require 'eudc)
32
33(defvar eudc-bob-generic-keymap nil
34 "Keymap for multimedia objects.")
35
36(defvar eudc-bob-image-keymap nil
37 "Keymap for inline images.")
38
39(defvar eudc-bob-sound-keymap nil
feb450e0 40 "Keymap for inline sounds.")
7970b229
GM
41
42(defvar eudc-bob-url-keymap nil
43 "Keymap for inline images.")
44
45(defconst eudc-bob-generic-menu
46 '("EUDC Binary Object Menu"
47 ["---" nil nil]
48 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
49 ["Save object" eudc-bob-save-object t]))
50
51(defconst eudc-bob-image-menu
52 `("EUDC Image Menu"
53 ["---" nil nil]
54 ["Toggle inline display" eudc-bob-toggle-inline-display
55 (eudc-bob-can-display-inline-images)]
56 ,@(cdr (cdr eudc-bob-generic-menu))))
57
58(defconst eudc-bob-sound-menu
59 `("EUDC Sound Menu"
60 ["---" nil nil]
61 ["Play sound" eudc-bob-play-sound-at-point
62 (fboundp 'play-sound)]
63 ,@(cdr (cdr eudc-bob-generic-menu))))
64
65(defun eudc-jump-to-event (event)
66 "Jump to the window and point where EVENT occurred."
67 (if eudc-xemacs-p
68 (goto-char (event-closest-point event))
69 (set-buffer (window-buffer (posn-window (event-start event))))
70 (goto-char (posn-point (event-start event)))))
71
72(defun eudc-bob-get-overlay-prop (prop)
73 "Get property PROP from one of the overlays around."
74 (let ((overlays (append (overlays-at (1- (point)))
75 (overlays-at (point))))
76 overlay value
77 (notfound t))
78 (while (and notfound
79 (setq overlay (car overlays)))
80 (if (setq value (overlay-get overlay prop))
81 (setq notfound nil))
82 (setq overlays (cdr overlays)))
83 value))
84
85(defun eudc-bob-can-display-inline-images ()
86 "Return non-nil if we can display images inline."
feb450e0
GM
87 (if eudc-xemacs-p
88 (and (memq (console-type) '(x mswindows))
89 (fboundp 'make-glyph))
90 (and (boundp 'image-types)
91 (not (null images-types)))))
7970b229
GM
92
93(defun eudc-bob-make-button (label keymap &optional menu plist)
94 "Create a button with LABEL.
95Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
96LABEL."
97 (let (overlay
98 (p (point))
99 prop val)
100 (insert label)
101 (put-text-property p (point) 'face 'bold)
102 (setq overlay (make-overlay p (point)))
103 (overlay-put overlay 'mouse-face 'highlight)
104 (overlay-put overlay 'keymap keymap)
105 (overlay-put overlay 'local-map keymap)
106 (overlay-put overlay 'menu menu)
107 (while plist
108 (setq prop (car plist)
109 plist (cdr plist)
110 val (car plist)
111 plist (cdr plist))
112 (overlay-put overlay prop val))))
113
114(defun eudc-bob-display-jpeg (data inline)
115 "Display the JPEG DATA at point.
feb450e0 116If INLINE is non-nil, try to inline the image otherwise simply
7970b229 117display a button."
feb450e0
GM
118 (cond (eudc-xemacs-p
119 (let ((glyph (if (eudc-bob-can-display-inline-images)
120 (make-glyph (list (vector 'jpeg :data data)
121 [string :data "[JPEG Picture]"])))))
122 (eudc-bob-make-button "[JPEG Picture]"
123 eudc-bob-image-keymap
124 eudc-bob-image-menu
125 (list 'glyph glyph
126 'end-glyph (if inline glyph)
127 'duplicable t
128 'invisible inline
129 'start-open t
130 'end-open t
131 'object-data data))))
132 (t
133 (let* ((image (create-image data nil t))
134 (props (list 'object-data data 'eudc-image image)))
135 (when inline
136 (setq props (nconc (list 'display image) props)))
137 (eudc-bob-make-button "[Picture]"
138 eudc-bob-image-keymap
139 eudc-bob-image-menu
140 props)))))
7970b229
GM
141
142(defun eudc-bob-toggle-inline-display ()
143 "Toggle inline display of an image."
144 (interactive)
feb450e0
GM
145 (when (eudc-bob-can-display-inline-images)
146 (cond (eudc-xemacs-p
147 (let ((overlays (append (overlays-at (1- (point)))
148 (overlays-at (point))))
149 overlay glyph)
150 (setq overlay (car overlays))
151 (while (and overlay
152 (not (setq glyph (overlay-get overlay 'glyph))))
153 (setq overlays (cdr overlays))
154 (setq overlay (car overlays)))
155 (if overlay
156 (if (overlay-get overlay 'end-glyph)
157 (progn
158 (overlay-put overlay 'end-glyph nil)
159 (overlay-put overlay 'invisible nil))
160 (overlay-put overlay 'end-glyph glyph)
161 (overlay-put overlay 'invisible t)))))
162 (t
163 (let* ((overlays (append (overlays-at (1- (point)))
164 (overlays-at (point))))
165 image)
166
167 ;; Search overlay with an image.
168 (while (and overlays (null image))
169 (let ((prop (overlay-get (car overlays) 'eudc-image)))
170 (if (imagep prop)
171 (setq image prop)
172 (setq overlays (cdr overlays)))))
173
174 ;; Toggle that overlay's image display.
175 (when overlays
176 (let ((overlay (car overlays)))
177 (overlay-put overlay 'display
178 (if (overlay-get overlay 'display)
179 nil image)))))))))
7970b229
GM
180
181(defun eudc-bob-display-audio (data)
182 "Display a button for audio DATA."
183 (eudc-bob-make-button "[Audio Sound]"
184 eudc-bob-sound-keymap
185 eudc-bob-sound-menu
186 (list 'duplicable t
187 'start-open t
188 'end-open t
189 'object-data data)))
190
7970b229
GM
191(defun eudc-bob-display-generic-binary (data)
192 "Display a button for unidentified binary DATA."
193 (eudc-bob-make-button "[Binary Data]"
194 eudc-bob-generic-keymap
195 eudc-bob-generic-menu
196 (list 'duplicable t
197 'start-open t
198 'end-open t
199 'object-data data)))
200
201(defun eudc-bob-play-sound-at-point ()
202 "Play the sound data contained in the button at point."
203 (interactive)
204 (let (sound)
205 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
206 (error "No sound data available here")
feb450e0
GM
207 (cond (eudc-xemacs-p
208 (if (not (and (boundp 'sound-alist)
209 sound-alist))
210 (error "Don't know how to play sound on this Emacs version")
211 (setq sound-alist
212 (cons (list 'eudc-sound
213 :sound sound)
214 sound-alist))
215 (condition-case nil
216 (play-sound 'eudc-sound)
217 (t
218 (setq sound-alist (cdr sound-alist))))))
219 (t
220 (unless (fboundp 'play-sound)
221 (error "Playing sounds not supported on this system"))
222 (play-sound (list 'sound :data sound)))))))
7970b229
GM
223
224
225(defun eudc-bob-play-sound-at-mouse (event)
226 "Play the sound data contained in the button where EVENT occurred."
227 (interactive "e")
228 (save-excursion
229 (eudc-jump-to-event event)
230 (eudc-bob-play-sound-at-point)))
231
232
233(defun eudc-bob-save-object ()
234 "Save the object data of the button at point."
235 (interactive)
236 (let ((data (eudc-bob-get-overlay-prop 'object-data))
237 (buffer (generate-new-buffer "*eudc-tmp*")))
238 (save-excursion
239 (if (fboundp 'set-buffer-file-coding-system)
240 (set-buffer-file-coding-system 'binary))
241 (set-buffer buffer)
242 (insert data)
243 (save-buffer))
244 (kill-buffer buffer)))
245
246(defun eudc-bob-pipe-object-to-external-program ()
247 "Pipe the object data of the button at point to an external program."
248 (interactive)
249 (let ((data (eudc-bob-get-overlay-prop 'object-data))
250 (buffer (generate-new-buffer "*eudc-tmp*"))
251 program
252 viewer)
253 (condition-case nil
254 (save-excursion
255 (if (fboundp 'set-buffer-file-coding-system)
256 (set-buffer-file-coding-system 'binary))
257 (set-buffer buffer)
258 (insert data)
259 (setq program (completing-read "Viewer: " eudc-external-viewers))
260 (if (setq viewer (assoc program eudc-external-viewers))
261 (call-process-region (point-min) (point-max)
262 (car (cdr viewer))
263 (cdr (cdr viewer)))
264 (call-process-region (point-min) (point-max) program)))
265 (t
266 (kill-buffer buffer)))))
267
268(defun eudc-bob-menu ()
269 "Retrieve the menu attached to a binary object."
270 (eudc-bob-get-overlay-prop 'menu))
271
272(defun eudc-bob-popup-menu (event)
273 "Pop-up a menu of EUDC multimedia commands."
274 (interactive "@e")
275 (run-hooks 'activate-menubar-hook)
276 (eudc-jump-to-event event)
277 (if eudc-xemacs-p
278 (progn
279 (run-hooks 'activate-popup-menu-hook)
280 (popup-menu (eudc-bob-menu)))
281 (let ((result (x-popup-menu t (eudc-bob-menu)))
282 command)
283 (if result
284 (progn
285 (setq command (lookup-key (eudc-bob-menu)
286 (apply 'vector result)))
287 (command-execute command))))))
288
289(setq eudc-bob-generic-keymap
290 (let ((map (make-sparse-keymap)))
291 (define-key map "s" 'eudc-bob-save-object)
292 (define-key map (if eudc-xemacs-p
293 [button3]
294 [down-mouse-3]) 'eudc-bob-popup-menu)
295 map))
296
297(setq eudc-bob-image-keymap
298 (let ((map (make-sparse-keymap)))
299 (define-key map "t" 'eudc-bob-toggle-inline-display)
300 map))
301
302(setq eudc-bob-sound-keymap
303 (let ((map (make-sparse-keymap)))
304 (define-key map [return] 'eudc-bob-play-sound-at-point)
305 (define-key map (if eudc-xemacs-p
306 [button2]
307 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
308 map))
309
310(setq eudc-bob-url-keymap
311 (let ((map (make-sparse-keymap)))
312 (define-key map [return] 'browse-url-at-point)
313 (define-key map (if eudc-xemacs-p
314 [button2]
315 [down-mouse-2]) 'browse-url-at-mouse)
316 map))
317
318(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
319(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
320
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-sound (data)
350 "Display a button to play the sound DATA."
351 (eudc-bob-display-audio data))
352
353;;;###autoload
354(defun eudc-display-jpeg-inline (data)
355 "Display the JPEG DATA inline at point if possible."
356 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
357
358;;;###autoload
359(defun eudc-display-jpeg-as-button (data)
360 "Display a button for the JPEG DATA."
361 (eudc-bob-display-jpeg data nil))
362
363;;; eudc-bob.el ends here