Mercurial > emacs
annotate lisp/net/eudc-bob.el @ 111453:5f5f21c6fca1
ChangeLog fix.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Tue, 09 Nov 2010 19:43:44 -0800 |
parents | 280c8ae2476d |
children | 417b1e4d63cd |
rev | line source |
---|---|
27313 | 1 ;;; eudc-bob.el --- Binary Objects Support for EUDC |
2 | |
104771
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, |
106815 | 4 ;; 2008, 2009, 2010 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 |
110015
280c8ae2476d
Add "Package:" file headers to denote built-in packages.
Chong Yidong <cyd@stupidchicken.com>
parents:
106815
diff
changeset
|
9 ;; Package: eudc |
27313 | 10 |
11 ;; This file is part of GNU Emacs. | |
12 | |
94677
91e5880a36c1
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
93975
diff
changeset
|
13 ;; GNU Emacs is free software: you can redistribute it and/or modify |
27313 | 14 ;; 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
|
15 ;; 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
|
16 ;; (at your option) any later version. |
27313 | 17 |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; 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
|
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
27313 | 25 |
38422
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
26 ;;; Commentary: |
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
27 |
27313 | 28 ;;; Usage: |
29 ;; See the corresponding info file | |
30 | |
31 ;;; Code: | |
32 | |
33 (require 'eudc) | |
34 | |
35 (defvar eudc-bob-generic-keymap nil | |
36 "Keymap for multimedia objects.") | |
37 | |
38 (defvar eudc-bob-image-keymap nil | |
39 "Keymap for inline images.") | |
40 | |
41 (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
|
42 "Keymap for inline sounds.") |
27313 | 43 |
44 (defvar eudc-bob-url-keymap nil | |
42519 | 45 "Keymap for inline urls.") |
27313 | 46 |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
47 (defvar eudc-bob-mail-keymap nil |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
48 "Keymap for inline e-mail addresses.") |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
49 |
104771
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
50 (defvar eudc-bob-generic-menu |
27313 | 51 '("EUDC Binary Object Menu" |
52 ["---" nil nil] | |
53 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] | |
54 ["Save object" eudc-bob-save-object t])) | |
55 | |
104771
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
56 (defvar eudc-bob-image-menu |
27313 | 57 `("EUDC Image Menu" |
58 ["---" nil nil] | |
59 ["Toggle inline display" eudc-bob-toggle-inline-display | |
60 (eudc-bob-can-display-inline-images)] | |
61 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
62 |
104771
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
63 (defvar eudc-bob-sound-menu |
27313 | 64 `("EUDC Sound Menu" |
65 ["---" nil nil] | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
66 ["Play sound" eudc-bob-play-sound-at-point |
27313 | 67 (fboundp 'play-sound)] |
68 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
69 |
27313 | 70 (defun eudc-jump-to-event (event) |
71 "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
|
72 (if (fboundp 'event-closest-point) |
27313 | 73 (goto-char (event-closest-point event)) |
74 (set-buffer (window-buffer (posn-window (event-start event)))) | |
75 (goto-char (posn-point (event-start event))))) | |
76 | |
77 (defun eudc-bob-get-overlay-prop (prop) | |
78 "Get property PROP from one of the overlays around." | |
79 (let ((overlays (append (overlays-at (1- (point))) | |
80 (overlays-at (point)))) | |
81 overlay value | |
82 (notfound t)) | |
83 (while (and notfound | |
84 (setq overlay (car overlays))) | |
85 (if (setq value (overlay-get overlay prop)) | |
86 (setq notfound nil)) | |
87 (setq overlays (cdr overlays))) | |
88 value)) | |
89 | |
90 (defun eudc-bob-can-display-inline-images () | |
91 "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
|
92 (if (fboundp 'console-type) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
93 (and (memq (console-type) '(x mswindows)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
94 (fboundp 'make-glyph)) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
95 (and (fboundp 'display-graphic-p) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
96 (display-graphic-p)))) |
27313 | 97 |
98 (defun eudc-bob-make-button (label keymap &optional menu plist) | |
99 "Create a button with LABEL. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
100 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
27313 | 101 LABEL." |
102 (let (overlay | |
103 (p (point)) | |
104 prop val) | |
105 (insert label) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
106 (put-text-property p (point) 'face 'bold) |
27313 | 107 (setq overlay (make-overlay p (point))) |
108 (overlay-put overlay 'mouse-face 'highlight) | |
109 (overlay-put overlay 'keymap keymap) | |
110 (overlay-put overlay 'local-map keymap) | |
111 (overlay-put overlay 'menu menu) | |
112 (while plist | |
113 (setq prop (car plist) | |
114 plist (cdr plist) | |
115 val (car plist) | |
116 plist (cdr plist)) | |
117 (overlay-put overlay prop val)))) | |
118 | |
119 (defun eudc-bob-display-jpeg (data inline) | |
120 "Display the JPEG DATA at point. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
121 If INLINE is non-nil, try to inline the image otherwise simply |
27313 | 122 display a button." |
64387
fea47ebca4ae
(eudc-jump-to-event): Avoid warning.
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
123 (cond ((fboundp 'make-glyph) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
124 (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
|
125 (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
|
126 [string :data "[JPEG Picture]"]))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
127 (eudc-bob-make-button "[JPEG Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
128 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
129 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
130 (list 'glyph glyph |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
131 'end-glyph (if inline glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
132 'duplicable t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
133 'invisible inline |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
134 'start-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
135 'end-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
136 'object-data data)))) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
137 ((fboundp 'create-image) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
138 (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
|
139 (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
|
140 (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
|
141 (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
|
142 (eudc-bob-make-button "[Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
143 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
144 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
145 props))))) |
27313 | 146 |
147 (defun eudc-bob-toggle-inline-display () | |
148 "Toggle inline display of an image." | |
149 (interactive) | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
150 (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
|
151 (cond ((featurep 'xemacs) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
152 (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
|
153 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
154 overlay glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
155 (setq overlay (car overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
156 (while (and overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
157 (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
|
158 (setq overlays (cdr overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
159 (setq overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
160 (if overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
161 (if (overlay-get overlay 'end-glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
162 (progn |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
163 (overlay-put overlay 'end-glyph nil) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
164 (overlay-put overlay 'invisible nil)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
165 (overlay-put overlay 'end-glyph glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
166 (overlay-put overlay 'invisible t))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
167 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
168 (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
|
169 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
170 image) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
171 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
172 ;; Search overlay with an image. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
173 (while (and overlays (null image)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
174 (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
|
175 (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
|
176 (setq image prop) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
177 (setq overlays (cdr overlays))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
178 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
179 ;; Toggle that overlay's image display. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
180 (when overlays |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
181 (let ((overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
182 (overlay-put overlay 'display |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
183 (if (overlay-get overlay 'display) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
184 nil image))))))))) |
27313 | 185 |
186 (defun eudc-bob-display-audio (data) | |
187 "Display a button for audio DATA." | |
188 (eudc-bob-make-button "[Audio Sound]" | |
189 eudc-bob-sound-keymap | |
190 eudc-bob-sound-menu | |
191 (list 'duplicable t | |
192 'start-open t | |
193 'end-open t | |
194 'object-data data))) | |
195 | |
196 (defun eudc-bob-display-generic-binary (data) | |
197 "Display a button for unidentified binary DATA." | |
198 (eudc-bob-make-button "[Binary Data]" | |
199 eudc-bob-generic-keymap | |
200 eudc-bob-generic-menu | |
201 (list 'duplicable t | |
202 'start-open t | |
203 'end-open t | |
204 'object-data data))) | |
205 | |
206 (defun eudc-bob-play-sound-at-point () | |
207 "Play the sound data contained in the button at point." | |
208 (interactive) | |
209 (let (sound) | |
210 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
211 (error "No sound data available here") | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
212 (unless (fboundp 'play-sound) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
213 (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
|
214 (play-sound (list 'sound :data sound))))) |
27313 | 215 |
216 (defun eudc-bob-play-sound-at-mouse (event) | |
217 "Play the sound data contained in the button where EVENT occurred." | |
218 (interactive "e") | |
219 (save-excursion | |
220 (eudc-jump-to-event event) | |
221 (eudc-bob-play-sound-at-point))) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
222 |
27313 | 223 (defun eudc-bob-save-object () |
224 "Save the object data of the button at point." | |
225 (interactive) | |
226 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
227 (buffer (generate-new-buffer "*eudc-tmp*"))) | |
228 (save-excursion | |
229 (if (fboundp 'set-buffer-file-coding-system) | |
230 (set-buffer-file-coding-system 'binary)) | |
231 (set-buffer buffer) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
232 (set-buffer-multibyte nil) |
27313 | 233 (insert data) |
234 (save-buffer)) | |
235 (kill-buffer buffer))) | |
236 | |
237 (defun eudc-bob-pipe-object-to-external-program () | |
238 "Pipe the object data of the button at point to an external program." | |
239 (interactive) | |
240 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
241 (buffer (generate-new-buffer "*eudc-tmp*")) | |
242 program | |
243 viewer) | |
244 (condition-case nil | |
245 (save-excursion | |
246 (if (fboundp 'set-buffer-file-coding-system) | |
247 (set-buffer-file-coding-system 'binary)) | |
248 (set-buffer buffer) | |
249 (insert data) | |
250 (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
251 (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
|
252 (call-process-region (point-min) (point-max) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
253 (car (cdr viewer)) |
27313 | 254 (cdr (cdr viewer))) |
255 (call-process-region (point-min) (point-max) program))) | |
105074
45b5d5aae703
Fix typos in condition-case handlers.
Glenn Morris <rgm@gnu.org>
parents:
104771
diff
changeset
|
256 (error |
27313 | 257 (kill-buffer buffer))))) |
258 | |
259 (defun eudc-bob-menu () | |
260 "Retrieve the menu attached to a binary object." | |
261 (eudc-bob-get-overlay-prop 'menu)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
262 |
27313 | 263 (defun eudc-bob-popup-menu (event) |
264 "Pop-up a menu of EUDC multimedia commands." | |
265 (interactive "@e") | |
266 (run-hooks 'activate-menubar-hook) | |
267 (eudc-jump-to-event event) | |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
268 (if (featurep 'xemacs) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
269 (progn |
27313 | 270 (run-hooks 'activate-popup-menu-hook) |
271 (popup-menu (eudc-bob-menu))) | |
272 (let ((result (x-popup-menu t (eudc-bob-menu))) | |
273 command) | |
274 (if result | |
275 (progn | |
276 (setq command (lookup-key (eudc-bob-menu) | |
277 (apply 'vector result))) | |
278 (command-execute command)))))) | |
279 | |
280 (setq eudc-bob-generic-keymap | |
281 (let ((map (make-sparse-keymap))) | |
282 (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
|
283 (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
|
284 (define-key map (if (featurep 'xemacs) |
27313 | 285 [button3] |
286 [down-mouse-3]) 'eudc-bob-popup-menu) | |
287 map)) | |
288 | |
289 (setq eudc-bob-image-keymap | |
290 (let ((map (make-sparse-keymap))) | |
291 (define-key map "t" 'eudc-bob-toggle-inline-display) | |
292 map)) | |
293 | |
294 (setq eudc-bob-sound-keymap | |
295 (let ((map (make-sparse-keymap))) | |
296 (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
|
297 (define-key map (if (featurep 'xemacs) |
27313 | 298 [button2] |
299 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
300 map)) | |
301 | |
302 (setq eudc-bob-url-keymap | |
303 (let ((map (make-sparse-keymap))) | |
304 (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
|
305 (define-key map (if (featurep 'xemacs) |
27313 | 306 [button2] |
307 [down-mouse-2]) 'browse-url-at-mouse) | |
308 map)) | |
309 | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
310 (setq eudc-bob-mail-keymap |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
311 (let ((map (make-sparse-keymap))) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
312 (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
|
313 (define-key map (if (featurep 'xemacs) |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
314 [button2] |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
315 [down-mouse-2]) 'goto-address-at-mouse) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
316 map)) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
317 |
27313 | 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 | |
104771
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
321 ;; If the first arguments can be nil here, then these 3 can be |
2c8224ca97e2
(eudc-bob-generic-menu, eudc-bob-image-menu)
Glenn Morris <rgm@gnu.org>
parents:
100908
diff
changeset
|
322 ;; defconsts once more. |
85511
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
323 (when (not (featurep 'xemacs)) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
324 (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
|
325 eudc-bob-generic-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
326 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
327 eudc-bob-generic-menu) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
328 (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
|
329 eudc-bob-image-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
330 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
331 eudc-bob-image-menu) |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
332 (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
|
333 eudc-bob-sound-keymap |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
334 "" |
f873840f9fea
* emulation/edt-mapper.el (function-key-map):
Dan Nicolaescu <dann@ics.uci.edu>
parents:
78230
diff
changeset
|
335 eudc-bob-sound-menu)) |
27313 | 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 | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
349 (defun eudc-display-mail (mail) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
350 "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
|
351 (require 'goto-addr) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
352 (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
|
353 |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
354 ;;;###autoload |
27313 | 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)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
368 |
93975
1e3a407766b9
Fix up comment convention on the arch-tag lines.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87649
diff
changeset
|
369 ;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3 |
27313 | 370 ;;; eudc-bob.el ends here |