Commit | Line | Data |
---|---|---|
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 | |
40 | "Keymap for inline images.") | |
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." | |
87 | (and eudc-xemacs-p | |
88 | (memq (console-type) | |
89 | '(x mswindows)) | |
90 | (fboundp 'make-glyph))) | |
91 | ||
92 | (defun eudc-bob-make-button (label keymap &optional menu plist) | |
93 | "Create a button with LABEL. | |
94 | Attach KEYMAP, MENU and properties from PLIST to a new overlay covering | |
95 | LABEL." | |
96 | (let (overlay | |
97 | (p (point)) | |
98 | prop val) | |
99 | (insert label) | |
100 | (put-text-property p (point) 'face 'bold) | |
101 | (setq overlay (make-overlay p (point))) | |
102 | (overlay-put overlay 'mouse-face 'highlight) | |
103 | (overlay-put overlay 'keymap keymap) | |
104 | (overlay-put overlay 'local-map keymap) | |
105 | (overlay-put overlay 'menu menu) | |
106 | (while plist | |
107 | (setq prop (car plist) | |
108 | plist (cdr plist) | |
109 | val (car plist) | |
110 | plist (cdr plist)) | |
111 | (overlay-put overlay prop val)))) | |
112 | ||
113 | (defun eudc-bob-display-jpeg (data inline) | |
114 | "Display the JPEG DATA at point. | |
115 | if INLINE is non-nil, try to inline the image otherwise simply | |
116 | display a button." | |
117 | (let ((glyph (if (eudc-bob-can-display-inline-images) | |
118 | (make-glyph (list (vector 'jpeg :data data) | |
119 | [string :data "[JPEG Picture]"]))))) | |
120 | (eudc-bob-make-button "[JPEG Picture]" | |
121 | eudc-bob-image-keymap | |
122 | eudc-bob-image-menu | |
123 | (list 'glyph glyph | |
124 | 'end-glyph (if inline glyph) | |
125 | 'duplicable t | |
126 | 'invisible inline | |
127 | 'start-open t | |
128 | 'end-open t | |
129 | 'object-data data)))) | |
130 | ||
131 | (defun eudc-bob-toggle-inline-display () | |
132 | "Toggle inline display of an image." | |
133 | (interactive) | |
134 | (if (eudc-bob-can-display-inline-images) | |
135 | (let ((overlays (append (overlays-at (1- (point))) | |
136 | (overlays-at (point)))) | |
137 | overlay glyph) | |
138 | (setq overlay (car overlays)) | |
139 | (while (and overlay | |
140 | (not (setq glyph (overlay-get overlay 'glyph)))) | |
141 | (setq overlays (cdr overlays)) | |
142 | (setq overlay (car overlays))) | |
143 | (if overlay | |
144 | (if (overlay-get overlay 'end-glyph) | |
145 | (progn | |
146 | (overlay-put overlay 'end-glyph nil) | |
147 | (overlay-put overlay 'invisible nil)) | |
148 | (overlay-put overlay 'end-glyph glyph) | |
149 | (overlay-put overlay 'invisible t)))))) | |
150 | ||
151 | (defun eudc-bob-display-audio (data) | |
152 | "Display a button for audio DATA." | |
153 | (eudc-bob-make-button "[Audio Sound]" | |
154 | eudc-bob-sound-keymap | |
155 | eudc-bob-sound-menu | |
156 | (list 'duplicable t | |
157 | 'start-open t | |
158 | 'end-open t | |
159 | 'object-data data))) | |
160 | ||
161 | ||
162 | (defun eudc-bob-display-generic-binary (data) | |
163 | "Display a button for unidentified binary DATA." | |
164 | (eudc-bob-make-button "[Binary Data]" | |
165 | eudc-bob-generic-keymap | |
166 | eudc-bob-generic-menu | |
167 | (list 'duplicable t | |
168 | 'start-open t | |
169 | 'end-open t | |
170 | 'object-data data))) | |
171 | ||
172 | (defun eudc-bob-play-sound-at-point () | |
173 | "Play the sound data contained in the button at point." | |
174 | (interactive) | |
175 | (let (sound) | |
176 | (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
177 | (error "No sound data available here") | |
178 | (if (not (and (boundp 'sound-alist) | |
179 | sound-alist)) | |
180 | (error "Don't know how to play sound on this Emacs version") | |
181 | (setq sound-alist | |
182 | (cons (list 'eudc-sound | |
183 | :sound sound) | |
184 | sound-alist)) | |
185 | (condition-case nil | |
186 | (play-sound 'eudc-sound) | |
187 | (t | |
188 | (setq sound-alist (cdr sound-alist)))))))) | |
189 | ||
190 | ||
191 | (defun eudc-bob-play-sound-at-mouse (event) | |
192 | "Play the sound data contained in the button where EVENT occurred." | |
193 | (interactive "e") | |
194 | (save-excursion | |
195 | (eudc-jump-to-event event) | |
196 | (eudc-bob-play-sound-at-point))) | |
197 | ||
198 | ||
199 | (defun eudc-bob-save-object () | |
200 | "Save the object data of the button at point." | |
201 | (interactive) | |
202 | (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
203 | (buffer (generate-new-buffer "*eudc-tmp*"))) | |
204 | (save-excursion | |
205 | (if (fboundp 'set-buffer-file-coding-system) | |
206 | (set-buffer-file-coding-system 'binary)) | |
207 | (set-buffer buffer) | |
208 | (insert data) | |
209 | (save-buffer)) | |
210 | (kill-buffer buffer))) | |
211 | ||
212 | (defun eudc-bob-pipe-object-to-external-program () | |
213 | "Pipe the object data of the button at point to an external program." | |
214 | (interactive) | |
215 | (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
216 | (buffer (generate-new-buffer "*eudc-tmp*")) | |
217 | program | |
218 | viewer) | |
219 | (condition-case nil | |
220 | (save-excursion | |
221 | (if (fboundp 'set-buffer-file-coding-system) | |
222 | (set-buffer-file-coding-system 'binary)) | |
223 | (set-buffer buffer) | |
224 | (insert data) | |
225 | (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
226 | (if (setq viewer (assoc program eudc-external-viewers)) | |
227 | (call-process-region (point-min) (point-max) | |
228 | (car (cdr viewer)) | |
229 | (cdr (cdr viewer))) | |
230 | (call-process-region (point-min) (point-max) program))) | |
231 | (t | |
232 | (kill-buffer buffer))))) | |
233 | ||
234 | (defun eudc-bob-menu () | |
235 | "Retrieve the menu attached to a binary object." | |
236 | (eudc-bob-get-overlay-prop 'menu)) | |
237 | ||
238 | (defun eudc-bob-popup-menu (event) | |
239 | "Pop-up a menu of EUDC multimedia commands." | |
240 | (interactive "@e") | |
241 | (run-hooks 'activate-menubar-hook) | |
242 | (eudc-jump-to-event event) | |
243 | (if eudc-xemacs-p | |
244 | (progn | |
245 | (run-hooks 'activate-popup-menu-hook) | |
246 | (popup-menu (eudc-bob-menu))) | |
247 | (let ((result (x-popup-menu t (eudc-bob-menu))) | |
248 | command) | |
249 | (if result | |
250 | (progn | |
251 | (setq command (lookup-key (eudc-bob-menu) | |
252 | (apply 'vector result))) | |
253 | (command-execute command)))))) | |
254 | ||
255 | (setq eudc-bob-generic-keymap | |
256 | (let ((map (make-sparse-keymap))) | |
257 | (define-key map "s" 'eudc-bob-save-object) | |
258 | (define-key map (if eudc-xemacs-p | |
259 | [button3] | |
260 | [down-mouse-3]) 'eudc-bob-popup-menu) | |
261 | map)) | |
262 | ||
263 | (setq eudc-bob-image-keymap | |
264 | (let ((map (make-sparse-keymap))) | |
265 | (define-key map "t" 'eudc-bob-toggle-inline-display) | |
266 | map)) | |
267 | ||
268 | (setq eudc-bob-sound-keymap | |
269 | (let ((map (make-sparse-keymap))) | |
270 | (define-key map [return] 'eudc-bob-play-sound-at-point) | |
271 | (define-key map (if eudc-xemacs-p | |
272 | [button2] | |
273 | [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
274 | map)) | |
275 | ||
276 | (setq eudc-bob-url-keymap | |
277 | (let ((map (make-sparse-keymap))) | |
278 | (define-key map [return] 'browse-url-at-point) | |
279 | (define-key map (if eudc-xemacs-p | |
280 | [button2] | |
281 | [down-mouse-2]) 'browse-url-at-mouse) | |
282 | map)) | |
283 | ||
284 | (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) | |
285 | (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) | |
286 | ||
287 | ||
288 | (if eudc-emacs-p | |
289 | (progn | |
290 | (easy-menu-define eudc-bob-generic-menu | |
291 | eudc-bob-generic-keymap | |
292 | "" | |
293 | eudc-bob-generic-menu) | |
294 | (easy-menu-define eudc-bob-image-menu | |
295 | eudc-bob-image-keymap | |
296 | "" | |
297 | eudc-bob-image-menu) | |
298 | (easy-menu-define eudc-bob-sound-menu | |
299 | eudc-bob-sound-keymap | |
300 | "" | |
301 | eudc-bob-sound-menu))) | |
302 | ||
303 | ;;;###autoload | |
304 | (defun eudc-display-generic-binary (data) | |
305 | "Display a button for unidentified binary DATA." | |
306 | (eudc-bob-display-generic-binary data)) | |
307 | ||
308 | ;;;###autoload | |
309 | (defun eudc-display-url (url) | |
310 | "Display URL and make it clickable." | |
311 | (require 'browse-url) | |
312 | (eudc-bob-make-button url eudc-bob-url-keymap)) | |
313 | ||
314 | ;;;###autoload | |
315 | (defun eudc-display-sound (data) | |
316 | "Display a button to play the sound DATA." | |
317 | (eudc-bob-display-audio data)) | |
318 | ||
319 | ;;;###autoload | |
320 | (defun eudc-display-jpeg-inline (data) | |
321 | "Display the JPEG DATA inline at point if possible." | |
322 | (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) | |
323 | ||
324 | ;;;###autoload | |
325 | (defun eudc-display-jpeg-as-button (data) | |
326 | "Display a button for the JPEG DATA." | |
327 | (eudc-bob-display-jpeg data nil)) | |
328 | ||
329 | ;;; eudc-bob.el ends here |