Mercurial > emacs
annotate lisp/net/eudc-bob.el @ 34360:c6d74397e65f
(tparam1): Change the way buffers are reallocated to be
portable and less obfuscated.
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Fri, 08 Dec 2000 09:58:48 +0000 |
parents | 92a7f3557095 |
children | 7a94f1c588c4 |
rev | line source |
---|---|
27313 | 1 ;;; eudc-bob.el --- Binary Objects Support for EUDC |
2 | |
3 ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Oscar Figueiredo <oscar@xemacs.org> | |
6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org> | |
7 ;; Keywords: help | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
24 ;; Boston, MA 02111-1307, USA. | |
25 | |
26 ;;; Usage: | |
27 ;; See the corresponding info file | |
28 | |
29 ;;; Code: | |
30 | |
31 (require 'eudc) | |
32 | |
33 (defvar eudc-bob-generic-keymap nil | |
34 "Keymap for multimedia objects.") | |
35 | |
36 (defvar eudc-bob-image-keymap nil | |
37 "Keymap for inline images.") | |
38 | |
39 (defvar eudc-bob-sound-keymap nil | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
40 "Keymap for inline sounds.") |
27313 | 41 |
42 (defvar eudc-bob-url-keymap nil | |
43 "Keymap for inline images.") | |
44 | |
45 (defconst eudc-bob-generic-menu | |
46 '("EUDC Binary Object Menu" | |
47 ["---" nil nil] | |
48 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] | |
49 ["Save object" eudc-bob-save-object t])) | |
50 | |
51 (defconst eudc-bob-image-menu | |
52 `("EUDC Image Menu" | |
53 ["---" nil nil] | |
54 ["Toggle inline display" eudc-bob-toggle-inline-display | |
55 (eudc-bob-can-display-inline-images)] | |
56 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
57 | |
58 (defconst eudc-bob-sound-menu | |
59 `("EUDC Sound Menu" | |
60 ["---" nil nil] | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
61 ["Play sound" eudc-bob-play-sound-at-point |
27313 | 62 (fboundp 'play-sound)] |
63 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
64 | |
65 (defun eudc-jump-to-event (event) | |
66 "Jump to the window and point where EVENT occurred." | |
67 (if eudc-xemacs-p | |
68 (goto-char (event-closest-point event)) | |
69 (set-buffer (window-buffer (posn-window (event-start event)))) | |
70 (goto-char (posn-point (event-start event))))) | |
71 | |
72 (defun eudc-bob-get-overlay-prop (prop) | |
73 "Get property PROP from one of the overlays around." | |
74 (let ((overlays (append (overlays-at (1- (point))) | |
75 (overlays-at (point)))) | |
76 overlay value | |
77 (notfound t)) | |
78 (while (and notfound | |
79 (setq overlay (car overlays))) | |
80 (if (setq value (overlay-get overlay prop)) | |
81 (setq notfound nil)) | |
82 (setq overlays (cdr overlays))) | |
83 value)) | |
84 | |
85 (defun eudc-bob-can-display-inline-images () | |
86 "Return non-nil if we can display images inline." | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
87 (if eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
88 (and (memq (console-type) '(x mswindows)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
89 (fboundp 'make-glyph)) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
90 (and (boundp 'display-graphic-p) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
91 (display-graphic-p)))) |
27313 | 92 |
93 (defun eudc-bob-make-button (label keymap &optional menu plist) | |
94 "Create a button with LABEL. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
95 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
27313 | 96 LABEL." |
97 (let (overlay | |
98 (p (point)) | |
99 prop val) | |
100 (insert label) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
101 (put-text-property p (point) 'face 'bold) |
27313 | 102 (setq overlay (make-overlay p (point))) |
103 (overlay-put overlay 'mouse-face 'highlight) | |
104 (overlay-put overlay 'keymap keymap) | |
105 (overlay-put overlay 'local-map keymap) | |
106 (overlay-put overlay 'menu menu) | |
107 (while plist | |
108 (setq prop (car plist) | |
109 plist (cdr plist) | |
110 val (car plist) | |
111 plist (cdr plist)) | |
112 (overlay-put overlay prop val)))) | |
113 | |
114 (defun eudc-bob-display-jpeg (data inline) | |
115 "Display the JPEG DATA at point. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
116 If INLINE is non-nil, try to inline the image otherwise simply |
27313 | 117 display a button." |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
118 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
119 (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
|
120 (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
|
121 [string :data "[JPEG Picture]"]))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
122 (eudc-bob-make-button "[JPEG Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
123 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
124 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
125 (list 'glyph glyph |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
126 'end-glyph (if inline glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
127 'duplicable t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
128 'invisible inline |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
129 'start-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
130 'end-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
131 'object-data data)))) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
132 ((boundp 'create-image) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
133 (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
|
134 (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
|
135 (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
|
136 (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
|
137 (eudc-bob-make-button "[Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
138 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
139 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
140 props))))) |
27313 | 141 |
142 (defun eudc-bob-toggle-inline-display () | |
143 "Toggle inline display of an image." | |
144 (interactive) | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
145 (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
|
146 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
147 (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
|
148 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
149 overlay glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
150 (setq overlay (car overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
151 (while (and overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
152 (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
|
153 (setq overlays (cdr overlays)) |
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 (if overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
156 (if (overlay-get overlay 'end-glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
157 (progn |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
158 (overlay-put overlay 'end-glyph nil) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
159 (overlay-put overlay 'invisible nil)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
160 (overlay-put overlay 'end-glyph glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
161 (overlay-put overlay 'invisible t))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
162 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
163 (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
|
164 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
165 image) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
166 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
167 ;; Search overlay with an image. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
168 (while (and overlays (null image)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
169 (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
|
170 (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
|
171 (setq image prop) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
172 (setq overlays (cdr overlays))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
173 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
174 ;; Toggle that overlay's image display. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
175 (when overlays |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
176 (let ((overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
177 (overlay-put overlay 'display |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
178 (if (overlay-get overlay 'display) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
179 nil image))))))))) |
27313 | 180 |
181 (defun eudc-bob-display-audio (data) | |
182 "Display a button for audio DATA." | |
183 (eudc-bob-make-button "[Audio Sound]" | |
184 eudc-bob-sound-keymap | |
185 eudc-bob-sound-menu | |
186 (list 'duplicable t | |
187 'start-open t | |
188 'end-open t | |
189 'object-data data))) | |
190 | |
191 (defun eudc-bob-display-generic-binary (data) | |
192 "Display a button for unidentified binary DATA." | |
193 (eudc-bob-make-button "[Binary Data]" | |
194 eudc-bob-generic-keymap | |
195 eudc-bob-generic-menu | |
196 (list 'duplicable t | |
197 'start-open t | |
198 'end-open t | |
199 'object-data data))) | |
200 | |
201 (defun eudc-bob-play-sound-at-point () | |
202 "Play the sound data contained in the button at point." | |
203 (interactive) | |
204 (let (sound) | |
205 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
206 (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
|
207 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
208 (if (not (and (boundp 'sound-alist) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
209 sound-alist)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
210 (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
|
211 (setq sound-alist |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
212 (cons (list 'eudc-sound |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
213 :sound sound) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
214 sound-alist)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
215 (condition-case nil |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
216 (play-sound 'eudc-sound) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
217 (t |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
218 (setq sound-alist (cdr sound-alist)))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
219 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
220 (unless (fboundp 'play-sound) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
221 (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
|
222 (play-sound (list 'sound :data sound))))))) |
27313 | 223 |
224 | |
225 (defun eudc-bob-play-sound-at-mouse (event) | |
226 "Play the sound data contained in the button where EVENT occurred." | |
227 (interactive "e") | |
228 (save-excursion | |
229 (eudc-jump-to-event event) | |
230 (eudc-bob-play-sound-at-point))) | |
231 | |
232 | |
233 (defun eudc-bob-save-object () | |
234 "Save the object data of the button at point." | |
235 (interactive) | |
236 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
237 (buffer (generate-new-buffer "*eudc-tmp*"))) | |
238 (save-excursion | |
239 (if (fboundp 'set-buffer-file-coding-system) | |
240 (set-buffer-file-coding-system 'binary)) | |
241 (set-buffer buffer) | |
242 (insert data) | |
243 (save-buffer)) | |
244 (kill-buffer buffer))) | |
245 | |
246 (defun eudc-bob-pipe-object-to-external-program () | |
247 "Pipe the object data of the button at point to an external program." | |
248 (interactive) | |
249 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
250 (buffer (generate-new-buffer "*eudc-tmp*")) | |
251 program | |
252 viewer) | |
253 (condition-case nil | |
254 (save-excursion | |
255 (if (fboundp 'set-buffer-file-coding-system) | |
256 (set-buffer-file-coding-system 'binary)) | |
257 (set-buffer buffer) | |
258 (insert data) | |
259 (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
260 (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
|
261 (call-process-region (point-min) (point-max) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
262 (car (cdr viewer)) |
27313 | 263 (cdr (cdr viewer))) |
264 (call-process-region (point-min) (point-max) program))) | |
265 (t | |
266 (kill-buffer buffer))))) | |
267 | |
268 (defun eudc-bob-menu () | |
269 "Retrieve the menu attached to a binary object." | |
270 (eudc-bob-get-overlay-prop 'menu)) | |
271 | |
272 (defun eudc-bob-popup-menu (event) | |
273 "Pop-up a menu of EUDC multimedia commands." | |
274 (interactive "@e") | |
275 (run-hooks 'activate-menubar-hook) | |
276 (eudc-jump-to-event event) | |
277 (if eudc-xemacs-p | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
278 (progn |
27313 | 279 (run-hooks 'activate-popup-menu-hook) |
280 (popup-menu (eudc-bob-menu))) | |
281 (let ((result (x-popup-menu t (eudc-bob-menu))) | |
282 command) | |
283 (if result | |
284 (progn | |
285 (setq command (lookup-key (eudc-bob-menu) | |
286 (apply 'vector result))) | |
287 (command-execute command)))))) | |
288 | |
289 (setq eudc-bob-generic-keymap | |
290 (let ((map (make-sparse-keymap))) | |
291 (define-key map "s" 'eudc-bob-save-object) | |
292 (define-key map (if eudc-xemacs-p | |
293 [button3] | |
294 [down-mouse-3]) 'eudc-bob-popup-menu) | |
295 map)) | |
296 | |
297 (setq eudc-bob-image-keymap | |
298 (let ((map (make-sparse-keymap))) | |
299 (define-key map "t" 'eudc-bob-toggle-inline-display) | |
300 map)) | |
301 | |
302 (setq eudc-bob-sound-keymap | |
303 (let ((map (make-sparse-keymap))) | |
304 (define-key map [return] 'eudc-bob-play-sound-at-point) | |
305 (define-key map (if eudc-xemacs-p | |
306 [button2] | |
307 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
308 map)) | |
309 | |
310 (setq eudc-bob-url-keymap | |
311 (let ((map (make-sparse-keymap))) | |
312 (define-key map [return] 'browse-url-at-point) | |
313 (define-key map (if eudc-xemacs-p | |
314 [button2] | |
315 [down-mouse-2]) 'browse-url-at-mouse) | |
316 map)) | |
317 | |
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 | |
321 | |
322 (if eudc-emacs-p | |
323 (progn | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
324 (easy-menu-define eudc-bob-generic-menu |
27313 | 325 eudc-bob-generic-keymap |
326 "" | |
327 eudc-bob-generic-menu) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
328 (easy-menu-define eudc-bob-image-menu |
27313 | 329 eudc-bob-image-keymap |
330 "" | |
331 eudc-bob-image-menu) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
332 (easy-menu-define eudc-bob-sound-menu |
27313 | 333 eudc-bob-sound-keymap |
334 "" | |
335 eudc-bob-sound-menu))) | |
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 | |
349 (defun eudc-display-sound (data) | |
350 "Display a button to play the sound DATA." | |
351 (eudc-bob-display-audio data)) | |
352 | |
353 ;;;###autoload | |
354 (defun eudc-display-jpeg-inline (data) | |
355 "Display the JPEG DATA inline at point if possible." | |
356 (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) | |
357 | |
358 ;;;###autoload | |
359 (defun eudc-display-jpeg-as-button (data) | |
360 "Display a button for the JPEG DATA." | |
361 (eudc-bob-display-jpeg data nil)) | |
362 | |
363 ;;; eudc-bob.el ends here |