Mercurial > emacs
annotate lisp/net/eudc-bob.el @ 97774:cf6404e22e31
*** empty log message ***
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Wed, 27 Aug 2008 20:21:31 +0000 |
parents | 91e5880a36c1 |
children | a9dc0e7c3f2b |
rev | line source |
---|---|
27313 | 1 ;;; eudc-bob.el --- Binary Objects Support for EUDC |
2 | |
74509 | 3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, |
79714 | 4 ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
27313 | 5 |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
6 ;; Author: Oscar Figueiredo <oscar@cpe.fr> |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
7 ;; Maintainer: Pavel Janík <Pavel@Janik.cz> |
42574 | 8 ;; Keywords: comm |
27313 | 9 |
10 ;; This file is part of GNU Emacs. | |
11 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
12 ;; GNU Emacs is free software: you can redistribute it and/or modify |
27313 | 13 ;; it under the terms of the GNU General Public License as published by |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
14 ;; the Free Software Foundation, either version 3 of the License, or |
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
15 ;; (at your option) any later version. |
27313 | 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 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
23 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
27313 | 24 |
38422
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
25 ;;; Commentary: |
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
26 |
27313 | 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 | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
41 "Keymap for inline sounds.") |
27313 | 42 |
43 (defvar eudc-bob-url-keymap nil | |
42519 | 44 "Keymap for inline urls.") |
27313 | 45 |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
46 (defvar eudc-bob-mail-keymap nil |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
47 "Keymap for inline e-mail addresses.") |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
48 |
27313 | 49 (defconst eudc-bob-generic-menu |
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 | |
55 (defconst eudc-bob-image-menu | |
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)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
61 |
27313 | 62 (defconst eudc-bob-sound-menu |
63 `("EUDC Sound Menu" | |
64 ["---" nil nil] | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
65 ["Play sound" eudc-bob-play-sound-at-point |
27313 | 66 (fboundp 'play-sound)] |
67 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
68 |
27313 | 69 (defun eudc-jump-to-event (event) |
70 "Jump to the window and point where EVENT occurred." | |
64387
fea47ebca4ae
(eudc-jump-to-event): Avoid warning.
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
71 (if (fboundp 'event-closest-point) |
27313 | 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." | |
64387
fea47ebca4ae
(eudc-jump-to-event): Avoid warning.
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
91 (if (fboundp 'console-type) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
92 (and (memq (console-type) '(x mswindows)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
93 (fboundp 'make-glyph)) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
94 (and (fboundp 'display-graphic-p) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
95 (display-graphic-p)))) |
27313 | 96 |
97 (defun eudc-bob-make-button (label keymap &optional menu plist) | |
98 "Create a button with LABEL. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
99 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
27313 | 100 LABEL." |
101 (let (overlay | |
102 (p (point)) | |
103 prop val) | |
104 (insert label) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
105 (put-text-property p (point) 'face 'bold) |
27313 | 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. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
120 If INLINE is non-nil, try to inline the image otherwise simply |
27313 | 121 display a button." |
64387
fea47ebca4ae
(eudc-jump-to-event): Avoid warning.
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
122 (cond ((fboundp 'make-glyph) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
123 (let ((glyph (if (eudc-bob-can-display-inline-images) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
124 (make-glyph (list (vector 'jpeg :data data) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
125 [string :data "[JPEG Picture]"]))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
126 (eudc-bob-make-button "[JPEG Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
127 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
128 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
129 (list 'glyph glyph |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
130 'end-glyph (if inline glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
131 'duplicable t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
132 'invisible inline |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
133 'start-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
134 'end-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
135 'object-data data)))) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
136 ((fboundp 'create-image) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
137 (let* ((image (create-image data nil t)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
138 (props (list 'object-data data 'eudc-image image))) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
139 (when (and inline (image-type-available-p 'jpeg)) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
140 (setq props (nconc (list 'display image) props))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
141 (eudc-bob-make-button "[Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
142 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
143 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
144 props))))) |
27313 | 145 |
146 (defun eudc-bob-toggle-inline-display () | |
147 "Toggle inline display of an image." | |
148 (interactive) | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
149 (when (eudc-bob-can-display-inline-images) |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
150 (cond ((featurep 'xemacs) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
151 (let ((overlays (append (overlays-at (1- (point))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
152 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
153 overlay glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
154 (setq overlay (car overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
155 (while (and overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
156 (not (setq glyph (overlay-get overlay 'glyph)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
157 (setq overlays (cdr overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
158 (setq overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
159 (if overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
160 (if (overlay-get overlay 'end-glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
161 (progn |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
162 (overlay-put overlay 'end-glyph nil) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
163 (overlay-put overlay 'invisible nil)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
164 (overlay-put overlay 'end-glyph glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
165 (overlay-put overlay 'invisible t))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
166 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
167 (let* ((overlays (append (overlays-at (1- (point))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
168 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
169 image) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
170 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
171 ;; Search overlay with an image. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
172 (while (and overlays (null image)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
173 (let ((prop (overlay-get (car overlays) 'eudc-image))) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
174 (if (eq 'image (car-safe prop)) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
175 (setq image prop) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
176 (setq overlays (cdr overlays))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
177 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
178 ;; Toggle that overlay's image display. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
179 (when overlays |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
180 (let ((overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
181 (overlay-put overlay 'display |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
182 (if (overlay-get overlay 'display) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
183 nil image))))))))) |
27313 | 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 | |
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") | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
211 (unless (fboundp 'play-sound) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
212 (error "Playing sounds not supported on this system")) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
213 (play-sound (list 'sound :data sound))))) |
27313 | 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))) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
221 |
27313 | 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) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
231 (set-buffer-multibyte nil) |
27313 | 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)) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
251 (call-process-region (point-min) (point-max) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
252 (car (cdr viewer)) |
27313 | 253 (cdr (cdr viewer))) |
254 (call-process-region (point-min) (point-max) program))) | |
255 (t | |
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)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
261 |
27313 | 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) | |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
267 (if (featurep 'xemacs) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
268 (progn |
27313 | 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) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
282 (define-key map "!" 'eudc-bob-pipe-object-to-external-program) |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
283 (define-key map (if (featurep 'xemacs) |
27313 | 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) | |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
296 (define-key map (if (featurep 'xemacs) |
27313 | 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) | |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
304 (define-key map (if (featurep 'xemacs) |
27313 | 305 [button2] |
306 [down-mouse-2]) 'browse-url-at-mouse) | |
307 map)) | |
308 | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
309 (setq eudc-bob-mail-keymap |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
310 (let ((map (make-sparse-keymap))) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
311 (define-key map [return] 'goto-address-at-point) |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
312 (define-key map (if (featurep 'xemacs) |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
313 [button2] |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
314 [down-mouse-2]) 'goto-address-at-mouse) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
315 map)) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
316 |
27313 | 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 | |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
320 (when (not (featurep 'xemacs)) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
321 (easy-menu-define eudc-bob-generic-menu |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
322 eudc-bob-generic-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
323 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
324 eudc-bob-generic-menu) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
325 (easy-menu-define eudc-bob-image-menu |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
326 eudc-bob-image-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
327 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
328 eudc-bob-image-menu) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
329 (easy-menu-define eudc-bob-sound-menu |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
330 eudc-bob-sound-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
331 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
332 eudc-bob-sound-menu)) |
27313 | 333 |
334 ;;;###autoload | |
335 (defun eudc-display-generic-binary (data) | |
336 "Display a button for unidentified binary DATA." | |
337 (eudc-bob-display-generic-binary data)) | |
338 | |
339 ;;;###autoload | |
340 (defun eudc-display-url (url) | |
341 "Display URL and make it clickable." | |
342 (require 'browse-url) | |
343 (eudc-bob-make-button url eudc-bob-url-keymap)) | |
344 | |
345 ;;;###autoload | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
346 (defun eudc-display-mail (mail) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
347 "Display e-mail address and make it clickable." |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
348 (require 'goto-addr) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
349 (eudc-bob-make-button mail eudc-bob-mail-keymap)) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
350 |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
351 ;;;###autoload |
27313 | 352 (defun eudc-display-sound (data) |
353 "Display a button to play the sound DATA." | |
354 (eudc-bob-display-audio data)) | |
355 | |
356 ;;;###autoload | |
357 (defun eudc-display-jpeg-inline (data) | |
358 "Display the JPEG DATA inline at point if possible." | |
359 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) | |
360 | |
361 ;;;###autoload | |
362 (defun eudc-display-jpeg-as-button (data) | |
363 "Display a button for the JPEG DATA." | |
364 (eudc-bob-display-jpeg data nil)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
365 |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87649
diff
changeset
|
366 ;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3 |
27313 | 367 ;;; eudc-bob.el ends here |