Commit | Line | Data |
---|---|---|
c38e0c97 | 1 | ;;; eudc-bob.el --- Binary Objects Support for EUDC -*- coding: utf-8 -*- |
7970b229 | 2 | |
ba318903 | 3 | ;; Copyright (C) 1999-2014 Free Software Foundation, Inc. |
7970b229 | 4 | |
774f6cf4 | 5 | ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
c38e0c97 | 6 | ;; Maintainer: Pavel Janík <Pavel@Janik.cz> |
ab651127 | 7 | ;; Keywords: comm |
bd78fa1d | 8 | ;; Package: eudc |
7970b229 GM |
9 | |
10 | ;; This file is part of GNU Emacs. | |
11 | ||
874a927a | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
7970b229 | 13 | ;; it under the terms of the GNU General Public License as published by |
874a927a GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
7970b229 GM |
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 | |
874a927a | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
7970b229 | 24 | |
3afbc435 PJ |
25 | ;;; Commentary: |
26 | ||
7970b229 GM |
27 | ;;; Usage: |
28 | ;; See the corresponding info file | |
29 | ||
30 | ;;; Code: | |
31 | ||
32 | (require 'eudc) | |
33 | ||
34 | (defvar eudc-bob-generic-keymap nil | |
35 | "Keymap for multimedia objects.") | |
36 | ||
37 | (defvar eudc-bob-image-keymap nil | |
38 | "Keymap for inline images.") | |
39 | ||
40 | (defvar eudc-bob-sound-keymap nil | |
feb450e0 | 41 | "Keymap for inline sounds.") |
7970b229 GM |
42 | |
43 | (defvar eudc-bob-url-keymap nil | |
748f3bf3 | 44 | "Keymap for inline urls.") |
7970b229 | 45 | |
774f6cf4 PJ |
46 | (defvar eudc-bob-mail-keymap nil |
47 | "Keymap for inline e-mail addresses.") | |
48 | ||
b0f3d955 | 49 | (defvar eudc-bob-generic-menu |
7970b229 GM |
50 | '("EUDC Binary Object Menu" |
51 | ["---" nil nil] | |
52 | ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] | |
53 | ["Save object" eudc-bob-save-object t])) | |
54 | ||
b0f3d955 | 55 | (defvar eudc-bob-image-menu |
7970b229 GM |
56 | `("EUDC Image Menu" |
57 | ["---" nil nil] | |
58 | ["Toggle inline display" eudc-bob-toggle-inline-display | |
59 | (eudc-bob-can-display-inline-images)] | |
60 | ,@(cdr (cdr eudc-bob-generic-menu)))) | |
aed3fbc3 | 61 | |
b0f3d955 | 62 | (defvar eudc-bob-sound-menu |
7970b229 GM |
63 | `("EUDC Sound Menu" |
64 | ["---" nil nil] | |
b12057b9 | 65 | ["Play sound" eudc-bob-play-sound-at-point |
7970b229 GM |
66 | (fboundp 'play-sound)] |
67 | ,@(cdr (cdr eudc-bob-generic-menu)))) | |
aed3fbc3 | 68 | |
7970b229 GM |
69 | (defun eudc-jump-to-event (event) |
70 | "Jump to the window and point where EVENT occurred." | |
8d25cef7 | 71 | (if (fboundp 'event-closest-point) |
7970b229 GM |
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))))) | |
75 | ||
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)))) | |
80 | overlay value | |
81 | (notfound t)) | |
82 | (while (and notfound | |
83 | (setq overlay (car overlays))) | |
84 | (if (setq value (overlay-get overlay prop)) | |
85 | (setq notfound nil)) | |
86 | (setq overlays (cdr overlays))) | |
87 | value)) | |
88 | ||
89 | (defun eudc-bob-can-display-inline-images () | |
90 | "Return non-nil if we can display images inline." | |
8d25cef7 | 91 | (if (fboundp 'console-type) |
feb450e0 GM |
92 | (and (memq (console-type) '(x mswindows)) |
93 | (fboundp 'make-glyph)) | |
665e6193 | 94 | (and (fboundp 'display-graphic-p) |
b12057b9 | 95 | (display-graphic-p)))) |
7970b229 GM |
96 | |
97 | (defun eudc-bob-make-button (label keymap &optional menu plist) | |
98 | "Create a button with LABEL. | |
b12057b9 | 99 | Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
7970b229 GM |
100 | LABEL." |
101 | (let (overlay | |
102 | (p (point)) | |
103 | prop val) | |
104 | (insert label) | |
b12057b9 | 105 | (put-text-property p (point) 'face 'bold) |
7970b229 GM |
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) | |
111 | (while plist | |
112 | (setq prop (car plist) | |
113 | plist (cdr plist) | |
114 | val (car plist) | |
115 | plist (cdr plist)) | |
116 | (overlay-put overlay prop val)))) | |
117 | ||
118 | (defun eudc-bob-display-jpeg (data inline) | |
119 | "Display the JPEG DATA at point. | |
b12057b9 | 120 | If INLINE is non-nil, try to inline the image otherwise simply |
7970b229 | 121 | display a button." |
8d25cef7 | 122 | (cond ((fboundp 'make-glyph) |
feb450e0 | 123 | (let ((glyph (if (eudc-bob-can-display-inline-images) |
b12057b9 | 124 | (make-glyph (list (vector 'jpeg :data data) |
feb450e0 GM |
125 | [string :data "[JPEG Picture]"]))))) |
126 | (eudc-bob-make-button "[JPEG Picture]" | |
127 | eudc-bob-image-keymap | |
128 | eudc-bob-image-menu | |
129 | (list 'glyph glyph | |
130 | 'end-glyph (if inline glyph) | |
131 | 'duplicable t | |
132 | 'invisible inline | |
133 | 'start-open t | |
134 | 'end-open t | |
135 | 'object-data data)))) | |
665e6193 | 136 | ((fboundp 'create-image) |
feb450e0 GM |
137 | (let* ((image (create-image data nil t)) |
138 | (props (list 'object-data data 'eudc-image image))) | |
b12057b9 | 139 | (when (and inline (image-type-available-p 'jpeg)) |
feb450e0 GM |
140 | (setq props (nconc (list 'display image) props))) |
141 | (eudc-bob-make-button "[Picture]" | |
142 | eudc-bob-image-keymap | |
143 | eudc-bob-image-menu | |
144 | props))))) | |
7970b229 GM |
145 | |
146 | (defun eudc-bob-toggle-inline-display () | |
147 | "Toggle inline display of an image." | |
148 | (interactive) | |
feb450e0 | 149 | (when (eudc-bob-can-display-inline-images) |
f8246027 | 150 | (cond ((featurep 'xemacs) |
feb450e0 GM |
151 | (let ((overlays (append (overlays-at (1- (point))) |
152 | (overlays-at (point)))) | |
153 | overlay glyph) | |
154 | (setq overlay (car overlays)) | |
155 | (while (and overlay | |
156 | (not (setq glyph (overlay-get overlay 'glyph)))) | |
157 | (setq overlays (cdr overlays)) | |
158 | (setq overlay (car overlays))) | |
159 | (if overlay | |
160 | (if (overlay-get overlay 'end-glyph) | |
161 | (progn | |
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))))) | |
166 | (t | |
167 | (let* ((overlays (append (overlays-at (1- (point))) | |
168 | (overlays-at (point)))) | |
169 | image) | |
170 | ||
171 | ;; Search overlay with an image. | |
172 | (while (and overlays (null image)) | |
173 | (let ((prop (overlay-get (car overlays) 'eudc-image))) | |
b12057b9 | 174 | (if (eq 'image (car-safe prop)) |
feb450e0 GM |
175 | (setq image prop) |
176 | (setq overlays (cdr overlays))))) | |
177 | ||
178 | ;; Toggle that overlay's image display. | |
179 | (when overlays | |
180 | (let ((overlay (car overlays))) | |
181 | (overlay-put overlay 'display | |
182 | (if (overlay-get overlay 'display) | |
183 | nil image))))))))) | |
7970b229 GM |
184 | |
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 | |
189 | eudc-bob-sound-menu | |
190 | (list 'duplicable t | |
191 | 'start-open t | |
192 | 'end-open t | |
193 | 'object-data data))) | |
194 | ||
7970b229 GM |
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 | |
200 | (list 'duplicable t | |
201 | 'start-open t | |
202 | 'end-open t | |
203 | 'object-data data))) | |
204 | ||
205 | (defun eudc-bob-play-sound-at-point () | |
206 | "Play the sound data contained in the button at point." | |
207 | (interactive) | |
208 | (let (sound) | |
209 | (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
210 | (error "No sound data available here") | |
774f6cf4 PJ |
211 | (unless (fboundp 'play-sound) |
212 | (error "Playing sounds not supported on this system")) | |
213 | (play-sound (list 'sound :data sound))))) | |
7970b229 GM |
214 | |
215 | (defun eudc-bob-play-sound-at-mouse (event) | |
216 | "Play the sound data contained in the button where EVENT occurred." | |
217 | (interactive "e") | |
218 | (save-excursion | |
219 | (eudc-jump-to-event event) | |
220 | (eudc-bob-play-sound-at-point))) | |
665e6193 | 221 | |
7970b229 GM |
222 | (defun eudc-bob-save-object () |
223 | "Save the object data of the button at point." | |
224 | (interactive) | |
225 | (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
226 | (buffer (generate-new-buffer "*eudc-tmp*"))) | |
227 | (save-excursion | |
228 | (if (fboundp 'set-buffer-file-coding-system) | |
229 | (set-buffer-file-coding-system 'binary)) | |
230 | (set-buffer buffer) | |
665e6193 | 231 | (set-buffer-multibyte nil) |
7970b229 GM |
232 | (insert data) |
233 | (save-buffer)) | |
234 | (kill-buffer buffer))) | |
235 | ||
236 | (defun eudc-bob-pipe-object-to-external-program () | |
237 | "Pipe the object data of the button at point to an external program." | |
238 | (interactive) | |
239 | (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
240 | (buffer (generate-new-buffer "*eudc-tmp*")) | |
241 | program | |
242 | viewer) | |
243 | (condition-case nil | |
244 | (save-excursion | |
245 | (if (fboundp 'set-buffer-file-coding-system) | |
246 | (set-buffer-file-coding-system 'binary)) | |
247 | (set-buffer buffer) | |
248 | (insert data) | |
249 | (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
250 | (if (setq viewer (assoc program eudc-external-viewers)) | |
b12057b9 DL |
251 | (call-process-region (point-min) (point-max) |
252 | (car (cdr viewer)) | |
7970b229 GM |
253 | (cdr (cdr viewer))) |
254 | (call-process-region (point-min) (point-max) program))) | |
6188ea49 | 255 | (error |
7970b229 GM |
256 | (kill-buffer buffer))))) |
257 | ||
258 | (defun eudc-bob-menu () | |
259 | "Retrieve the menu attached to a binary object." | |
260 | (eudc-bob-get-overlay-prop 'menu)) | |
aed3fbc3 | 261 | |
7970b229 GM |
262 | (defun eudc-bob-popup-menu (event) |
263 | "Pop-up a menu of EUDC multimedia commands." | |
264 | (interactive "@e") | |
265 | (run-hooks 'activate-menubar-hook) | |
266 | (eudc-jump-to-event event) | |
f8246027 | 267 | (if (featurep 'xemacs) |
b12057b9 | 268 | (progn |
7970b229 GM |
269 | (run-hooks 'activate-popup-menu-hook) |
270 | (popup-menu (eudc-bob-menu))) | |
271 | (let ((result (x-popup-menu t (eudc-bob-menu))) | |
272 | command) | |
273 | (if result | |
274 | (progn | |
275 | (setq command (lookup-key (eudc-bob-menu) | |
276 | (apply 'vector result))) | |
277 | (command-execute command)))))) | |
278 | ||
279 | (setq eudc-bob-generic-keymap | |
280 | (let ((map (make-sparse-keymap))) | |
281 | (define-key map "s" 'eudc-bob-save-object) | |
665e6193 | 282 | (define-key map "!" 'eudc-bob-pipe-object-to-external-program) |
f8246027 | 283 | (define-key map (if (featurep 'xemacs) |
7970b229 GM |
284 | [button3] |
285 | [down-mouse-3]) 'eudc-bob-popup-menu) | |
286 | map)) | |
287 | ||
288 | (setq eudc-bob-image-keymap | |
289 | (let ((map (make-sparse-keymap))) | |
290 | (define-key map "t" 'eudc-bob-toggle-inline-display) | |
291 | map)) | |
292 | ||
293 | (setq eudc-bob-sound-keymap | |
294 | (let ((map (make-sparse-keymap))) | |
295 | (define-key map [return] 'eudc-bob-play-sound-at-point) | |
f8246027 | 296 | (define-key map (if (featurep 'xemacs) |
7970b229 GM |
297 | [button2] |
298 | [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
299 | map)) | |
300 | ||
301 | (setq eudc-bob-url-keymap | |
302 | (let ((map (make-sparse-keymap))) | |
303 | (define-key map [return] 'browse-url-at-point) | |
f8246027 | 304 | (define-key map (if (featurep 'xemacs) |
7970b229 GM |
305 | [button2] |
306 | [down-mouse-2]) 'browse-url-at-mouse) | |
307 | map)) | |
308 | ||
774f6cf4 PJ |
309 | (setq eudc-bob-mail-keymap |
310 | (let ((map (make-sparse-keymap))) | |
311 | (define-key map [return] 'goto-address-at-point) | |
f8246027 | 312 | (define-key map (if (featurep 'xemacs) |
774f6cf4 PJ |
313 | [button2] |
314 | [down-mouse-2]) 'goto-address-at-mouse) | |
315 | map)) | |
316 | ||
7970b229 GM |
317 | (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) |
318 | (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) | |
319 | ||
b0f3d955 GM |
320 | ;; If the first arguments can be nil here, then these 3 can be |
321 | ;; defconsts once more. | |
f8246027 DN |
322 | (when (not (featurep 'xemacs)) |
323 | (easy-menu-define eudc-bob-generic-menu | |
324 | eudc-bob-generic-keymap | |
325 | "" | |
326 | eudc-bob-generic-menu) | |
327 | (easy-menu-define eudc-bob-image-menu | |
328 | eudc-bob-image-keymap | |
329 | "" | |
330 | eudc-bob-image-menu) | |
331 | (easy-menu-define eudc-bob-sound-menu | |
332 | eudc-bob-sound-keymap | |
333 | "" | |
334 | eudc-bob-sound-menu)) | |
7970b229 GM |
335 | |
336 | ;;;###autoload | |
337 | (defun eudc-display-generic-binary (data) | |
338 | "Display a button for unidentified binary DATA." | |
339 | (eudc-bob-display-generic-binary data)) | |
340 | ||
341 | ;;;###autoload | |
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)) | |
346 | ||
774f6cf4 PJ |
347 | ;;;###autoload |
348 | (defun eudc-display-mail (mail) | |
349 | "Display e-mail address and make it clickable." | |
350 | (require 'goto-addr) | |
351 | (eudc-bob-make-button mail eudc-bob-mail-keymap)) | |
352 | ||
7970b229 GM |
353 | ;;;###autoload |
354 | (defun eudc-display-sound (data) | |
355 | "Display a button to play the sound DATA." | |
356 | (eudc-bob-display-audio data)) | |
357 | ||
358 | ;;;###autoload | |
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))) | |
362 | ||
363 | ;;;###autoload | |
364 | (defun eudc-display-jpeg-as-button (data) | |
365 | "Display a button for the JPEG DATA." | |
366 | (eudc-bob-display-jpeg data nil)) | |
aed3fbc3 | 367 | |
7970b229 | 368 | ;;; eudc-bob.el ends here |