Mercurial > emacs
annotate lisp/net/eudc-bob.el @ 42597:255b72a74a90
*** empty log message ***
author | Jaeyoun Chung <jay@kldp.org> |
---|---|
date | Mon, 07 Jan 2002 07:36:15 +0000 |
parents | fcac9cd201ad |
children | c9c59300d7a6 |
rev | line source |
---|---|
27313 | 1 ;;; eudc-bob.el --- Binary Objects Support for EUDC |
2 | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
3 ;; Copyright (C) 1999, 2000, 2002 Free Software Foundation, Inc. |
27313 | 4 |
5 ;; Author: Oscar Figueiredo <oscar@xemacs.org> | |
6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org> | |
42574 | 7 ;; Keywords: comm |
27313 | 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 | |
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 |
47 (defconst eudc-bob-generic-menu | |
48 '("EUDC Binary Object Menu" | |
49 ["---" nil nil] | |
50 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] | |
51 ["Save object" eudc-bob-save-object t])) | |
52 | |
53 (defconst eudc-bob-image-menu | |
54 `("EUDC Image Menu" | |
55 ["---" nil nil] | |
56 ["Toggle inline display" eudc-bob-toggle-inline-display | |
57 (eudc-bob-can-display-inline-images)] | |
58 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
59 |
27313 | 60 (defconst eudc-bob-sound-menu |
61 `("EUDC Sound Menu" | |
62 ["---" nil nil] | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
63 ["Play sound" eudc-bob-play-sound-at-point |
27313 | 64 (fboundp 'play-sound)] |
65 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
66 |
27313 | 67 (defun eudc-jump-to-event (event) |
68 "Jump to the window and point where EVENT occurred." | |
69 (if eudc-xemacs-p | |
70 (goto-char (event-closest-point event)) | |
71 (set-buffer (window-buffer (posn-window (event-start event)))) | |
72 (goto-char (posn-point (event-start event))))) | |
73 | |
74 (defun eudc-bob-get-overlay-prop (prop) | |
75 "Get property PROP from one of the overlays around." | |
76 (let ((overlays (append (overlays-at (1- (point))) | |
77 (overlays-at (point)))) | |
78 overlay value | |
79 (notfound t)) | |
80 (while (and notfound | |
81 (setq overlay (car overlays))) | |
82 (if (setq value (overlay-get overlay prop)) | |
83 (setq notfound nil)) | |
84 (setq overlays (cdr overlays))) | |
85 value)) | |
86 | |
87 (defun eudc-bob-can-display-inline-images () | |
88 "Return non-nil if we can display images inline." | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
89 (if eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
90 (and (memq (console-type) '(x mswindows)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
91 (fboundp 'make-glyph)) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
92 (and (fboundp 'display-graphic-p) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
93 (display-graphic-p)))) |
27313 | 94 |
95 (defun eudc-bob-make-button (label keymap &optional menu plist) | |
96 "Create a button with LABEL. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
97 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
27313 | 98 LABEL." |
99 (let (overlay | |
100 (p (point)) | |
101 prop val) | |
102 (insert label) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
103 (put-text-property p (point) 'face 'bold) |
27313 | 104 (setq overlay (make-overlay p (point))) |
105 (overlay-put overlay 'mouse-face 'highlight) | |
106 (overlay-put overlay 'keymap keymap) | |
107 (overlay-put overlay 'local-map keymap) | |
108 (overlay-put overlay 'menu menu) | |
109 (while plist | |
110 (setq prop (car plist) | |
111 plist (cdr plist) | |
112 val (car plist) | |
113 plist (cdr plist)) | |
114 (overlay-put overlay prop val)))) | |
115 | |
116 (defun eudc-bob-display-jpeg (data inline) | |
117 "Display the JPEG DATA at point. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
118 If INLINE is non-nil, try to inline the image otherwise simply |
27313 | 119 display a button." |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
120 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
121 (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
|
122 (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
|
123 [string :data "[JPEG Picture]"]))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
124 (eudc-bob-make-button "[JPEG Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
125 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
126 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
127 (list 'glyph glyph |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
128 'end-glyph (if inline glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
129 'duplicable t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
130 'invisible inline |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
131 'start-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
132 'end-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
133 'object-data data)))) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
134 ((fboundp 'create-image) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
135 (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
|
136 (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
|
137 (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
|
138 (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
|
139 (eudc-bob-make-button "[Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
140 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
141 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
142 props))))) |
27313 | 143 |
144 (defun eudc-bob-toggle-inline-display () | |
145 "Toggle inline display of an image." | |
146 (interactive) | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
147 (when (eudc-bob-can-display-inline-images) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
148 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
149 (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
|
150 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
151 overlay glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
152 (setq overlay (car overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
153 (while (and overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
154 (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
|
155 (setq overlays (cdr overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
156 (setq overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
157 (if overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
158 (if (overlay-get overlay 'end-glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
159 (progn |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
160 (overlay-put overlay 'end-glyph nil) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
161 (overlay-put overlay 'invisible nil)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
162 (overlay-put overlay 'end-glyph glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
163 (overlay-put overlay 'invisible t))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
164 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
165 (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
|
166 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
167 image) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
168 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
169 ;; Search overlay with an image. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
170 (while (and overlays (null image)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
171 (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
|
172 (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
|
173 (setq image prop) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
174 (setq overlays (cdr overlays))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
175 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
176 ;; Toggle that overlay's image display. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
177 (when overlays |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
178 (let ((overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
179 (overlay-put overlay 'display |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
180 (if (overlay-get overlay 'display) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
181 nil image))))))))) |
27313 | 182 |
183 (defun eudc-bob-display-audio (data) | |
184 "Display a button for audio DATA." | |
185 (eudc-bob-make-button "[Audio Sound]" | |
186 eudc-bob-sound-keymap | |
187 eudc-bob-sound-menu | |
188 (list 'duplicable t | |
189 'start-open t | |
190 'end-open t | |
191 'object-data data))) | |
192 | |
193 (defun eudc-bob-display-generic-binary (data) | |
194 "Display a button for unidentified binary DATA." | |
195 (eudc-bob-make-button "[Binary Data]" | |
196 eudc-bob-generic-keymap | |
197 eudc-bob-generic-menu | |
198 (list 'duplicable t | |
199 'start-open t | |
200 'end-open t | |
201 'object-data data))) | |
202 | |
203 (defun eudc-bob-play-sound-at-point () | |
204 "Play the sound data contained in the button at point." | |
205 (interactive) | |
206 (let (sound) | |
207 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
208 (error "No sound data available here") | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
209 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
210 (if (not (and (boundp 'sound-alist) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
211 sound-alist)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
212 (error "Don't know how to play sound on this Emacs version") |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
213 (setq sound-alist |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
214 (cons (list 'eudc-sound |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
215 :sound sound) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
216 sound-alist)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
217 (condition-case nil |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
218 (play-sound 'eudc-sound) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
219 (t |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
220 (setq sound-alist (cdr sound-alist)))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
221 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
222 (unless (fboundp 'play-sound) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
223 (error "Playing sounds not supported on this system")) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
224 (play-sound (list 'sound :data sound))))))) |
27313 | 225 |
226 (defun eudc-bob-play-sound-at-mouse (event) | |
227 "Play the sound data contained in the button where EVENT occurred." | |
228 (interactive "e") | |
229 (save-excursion | |
230 (eudc-jump-to-event event) | |
231 (eudc-bob-play-sound-at-point))) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
232 |
27313 | 233 |
234 (defun eudc-bob-save-object () | |
235 "Save the object data of the button at point." | |
236 (interactive) | |
237 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
238 (buffer (generate-new-buffer "*eudc-tmp*"))) | |
239 (save-excursion | |
240 (if (fboundp 'set-buffer-file-coding-system) | |
241 (set-buffer-file-coding-system 'binary)) | |
242 (set-buffer buffer) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
243 (set-buffer-multibyte nil) |
27313 | 244 (insert data) |
245 (save-buffer)) | |
246 (kill-buffer buffer))) | |
247 | |
248 (defun eudc-bob-pipe-object-to-external-program () | |
249 "Pipe the object data of the button at point to an external program." | |
250 (interactive) | |
251 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
252 (buffer (generate-new-buffer "*eudc-tmp*")) | |
253 program | |
254 viewer) | |
255 (condition-case nil | |
256 (save-excursion | |
257 (if (fboundp 'set-buffer-file-coding-system) | |
258 (set-buffer-file-coding-system 'binary)) | |
259 (set-buffer buffer) | |
260 (insert data) | |
261 (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
262 (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
|
263 (call-process-region (point-min) (point-max) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
264 (car (cdr viewer)) |
27313 | 265 (cdr (cdr viewer))) |
266 (call-process-region (point-min) (point-max) program))) | |
267 (t | |
268 (kill-buffer buffer))))) | |
269 | |
270 (defun eudc-bob-menu () | |
271 "Retrieve the menu attached to a binary object." | |
272 (eudc-bob-get-overlay-prop 'menu)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
273 |
27313 | 274 (defun eudc-bob-popup-menu (event) |
275 "Pop-up a menu of EUDC multimedia commands." | |
276 (interactive "@e") | |
277 (run-hooks 'activate-menubar-hook) | |
278 (eudc-jump-to-event event) | |
279 (if eudc-xemacs-p | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
280 (progn |
27313 | 281 (run-hooks 'activate-popup-menu-hook) |
282 (popup-menu (eudc-bob-menu))) | |
283 (let ((result (x-popup-menu t (eudc-bob-menu))) | |
284 command) | |
285 (if result | |
286 (progn | |
287 (setq command (lookup-key (eudc-bob-menu) | |
288 (apply 'vector result))) | |
289 (command-execute command)))))) | |
290 | |
291 (setq eudc-bob-generic-keymap | |
292 (let ((map (make-sparse-keymap))) | |
293 (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
|
294 (define-key map "!" 'eudc-bob-pipe-object-to-external-program) |
27313 | 295 (define-key map (if eudc-xemacs-p |
296 [button3] | |
297 [down-mouse-3]) 'eudc-bob-popup-menu) | |
298 map)) | |
299 | |
300 (setq eudc-bob-image-keymap | |
301 (let ((map (make-sparse-keymap))) | |
302 (define-key map "t" 'eudc-bob-toggle-inline-display) | |
303 map)) | |
304 | |
305 (setq eudc-bob-sound-keymap | |
306 (let ((map (make-sparse-keymap))) | |
307 (define-key map [return] 'eudc-bob-play-sound-at-point) | |
308 (define-key map (if eudc-xemacs-p | |
309 [button2] | |
310 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
311 map)) | |
312 | |
313 (setq eudc-bob-url-keymap | |
314 (let ((map (make-sparse-keymap))) | |
315 (define-key map [return] 'browse-url-at-point) | |
316 (define-key map (if eudc-xemacs-p | |
317 [button2] | |
318 [down-mouse-2]) 'browse-url-at-mouse) | |
319 map)) | |
320 | |
321 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) | |
322 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) | |
323 | |
324 (if eudc-emacs-p | |
325 (progn | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
326 (easy-menu-define eudc-bob-generic-menu |
27313 | 327 eudc-bob-generic-keymap |
328 "" | |
329 eudc-bob-generic-menu) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
330 (easy-menu-define eudc-bob-image-menu |
27313 | 331 eudc-bob-image-keymap |
332 "" | |
333 eudc-bob-image-menu) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
334 (easy-menu-define eudc-bob-sound-menu |
27313 | 335 eudc-bob-sound-keymap |
336 "" | |
337 eudc-bob-sound-menu))) | |
338 | |
339 ;;;###autoload | |
340 (defun eudc-display-generic-binary (data) | |
341 "Display a button for unidentified binary DATA." | |
342 (eudc-bob-display-generic-binary data)) | |
343 | |
344 ;;;###autoload | |
345 (defun eudc-display-url (url) | |
346 "Display URL and make it clickable." | |
347 (require 'browse-url) | |
348 (eudc-bob-make-button url eudc-bob-url-keymap)) | |
349 | |
350 ;;;###autoload | |
351 (defun eudc-display-sound (data) | |
352 "Display a button to play the sound DATA." | |
353 (eudc-bob-display-audio data)) | |
354 | |
355 ;;;###autoload | |
356 (defun eudc-display-jpeg-inline (data) | |
357 "Display the JPEG DATA inline at point if possible." | |
358 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) | |
359 | |
360 ;;;###autoload | |
361 (defun eudc-display-jpeg-as-button (data) | |
362 "Display a button for the JPEG DATA." | |
363 (eudc-bob-display-jpeg data nil)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
364 |
27313 | 365 ;;; eudc-bob.el ends here |