Mercurial > emacs
annotate lisp/net/eudc-bob.el @ 84671:f061115a812f
*** empty log message ***
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Thu, 20 Sep 2007 02:53:58 +0000 |
parents | 84cf1e2214c5 |
children | 6888fd3398e8 f873840f9fea f55f9811f5d7 |
rev | line source |
---|---|
27313 | 1 ;;; eudc-bob.el --- Binary Objects Support for EUDC |
2 | |
74509 | 3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, |
75347 | 4 ;; 2005, 2006, 2007 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 | |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;; it under the terms of the GNU General Public License as published by | |
78230
84cf1e2214c5
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
75347
diff
changeset
|
14 ;; the Free Software Foundation; either version 3, or (at your option) |
27313 | 15 ;; any later version. |
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 | |
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
64085 | 24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
25 ;; Boston, MA 02110-1301, USA. | |
27313 | 26 |
38422
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
27 ;;; Commentary: |
7a94f1c588c4
Some fixes to follow coding conventions.
Pavel Janík <Pavel@Janik.cz>
parents:
33516
diff
changeset
|
28 |
27313 | 29 ;;; Usage: |
30 ;; See the corresponding info file | |
31 | |
32 ;;; Code: | |
33 | |
34 (require 'eudc) | |
35 | |
36 (defvar eudc-bob-generic-keymap nil | |
37 "Keymap for multimedia objects.") | |
38 | |
39 (defvar eudc-bob-image-keymap nil | |
40 "Keymap for inline images.") | |
41 | |
42 (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
|
43 "Keymap for inline sounds.") |
27313 | 44 |
45 (defvar eudc-bob-url-keymap nil | |
42519 | 46 "Keymap for inline urls.") |
27313 | 47 |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
48 (defvar eudc-bob-mail-keymap nil |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
49 "Keymap for inline e-mail addresses.") |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
50 |
27313 | 51 (defconst eudc-bob-generic-menu |
52 '("EUDC Binary Object Menu" | |
53 ["---" nil nil] | |
54 ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] | |
55 ["Save object" eudc-bob-save-object t])) | |
56 | |
57 (defconst eudc-bob-image-menu | |
58 `("EUDC Image Menu" | |
59 ["---" nil nil] | |
60 ["Toggle inline display" eudc-bob-toggle-inline-display | |
61 (eudc-bob-can-display-inline-images)] | |
62 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
63 |
27313 | 64 (defconst eudc-bob-sound-menu |
65 `("EUDC Sound Menu" | |
66 ["---" nil nil] | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
67 ["Play sound" eudc-bob-play-sound-at-point |
27313 | 68 (fboundp 'play-sound)] |
69 ,@(cdr (cdr eudc-bob-generic-menu)))) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
70 |
27313 | 71 (defun eudc-jump-to-event (event) |
72 "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
|
73 (if (fboundp 'event-closest-point) |
27313 | 74 (goto-char (event-closest-point event)) |
75 (set-buffer (window-buffer (posn-window (event-start event)))) | |
76 (goto-char (posn-point (event-start event))))) | |
77 | |
78 (defun eudc-bob-get-overlay-prop (prop) | |
79 "Get property PROP from one of the overlays around." | |
80 (let ((overlays (append (overlays-at (1- (point))) | |
81 (overlays-at (point)))) | |
82 overlay value | |
83 (notfound t)) | |
84 (while (and notfound | |
85 (setq overlay (car overlays))) | |
86 (if (setq value (overlay-get overlay prop)) | |
87 (setq notfound nil)) | |
88 (setq overlays (cdr overlays))) | |
89 value)) | |
90 | |
91 (defun eudc-bob-can-display-inline-images () | |
92 "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
|
93 (if (fboundp 'console-type) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
94 (and (memq (console-type) '(x mswindows)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
95 (fboundp 'make-glyph)) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
96 (and (fboundp 'display-graphic-p) |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
97 (display-graphic-p)))) |
27313 | 98 |
99 (defun eudc-bob-make-button (label keymap &optional menu plist) | |
100 "Create a button with LABEL. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
101 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering |
27313 | 102 LABEL." |
103 (let (overlay | |
104 (p (point)) | |
105 prop val) | |
106 (insert label) | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
107 (put-text-property p (point) 'face 'bold) |
27313 | 108 (setq overlay (make-overlay p (point))) |
109 (overlay-put overlay 'mouse-face 'highlight) | |
110 (overlay-put overlay 'keymap keymap) | |
111 (overlay-put overlay 'local-map keymap) | |
112 (overlay-put overlay 'menu menu) | |
113 (while plist | |
114 (setq prop (car plist) | |
115 plist (cdr plist) | |
116 val (car plist) | |
117 plist (cdr plist)) | |
118 (overlay-put overlay prop val)))) | |
119 | |
120 (defun eudc-bob-display-jpeg (data inline) | |
121 "Display the JPEG DATA at point. | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
122 If INLINE is non-nil, try to inline the image otherwise simply |
27313 | 123 display a button." |
64387
fea47ebca4ae
(eudc-jump-to-event): Avoid warning.
Richard M. Stallman <rms@gnu.org>
parents:
64085
diff
changeset
|
124 (cond ((fboundp 'make-glyph) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
125 (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
|
126 (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
|
127 [string :data "[JPEG Picture]"]))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
128 (eudc-bob-make-button "[JPEG Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
129 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
130 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
131 (list 'glyph glyph |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
132 'end-glyph (if inline glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
133 'duplicable t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
134 'invisible inline |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
135 'start-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
136 'end-open t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
137 'object-data data)))) |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
138 ((fboundp 'create-image) |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
139 (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
|
140 (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
|
141 (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
|
142 (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
|
143 (eudc-bob-make-button "[Picture]" |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
144 eudc-bob-image-keymap |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
145 eudc-bob-image-menu |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
146 props))))) |
27313 | 147 |
148 (defun eudc-bob-toggle-inline-display () | |
149 "Toggle inline display of an image." | |
150 (interactive) | |
27317
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
151 (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
|
152 (cond (eudc-xemacs-p |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
153 (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
|
154 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
155 overlay glyph) |
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 (while (and overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
158 (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
|
159 (setq overlays (cdr overlays)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
160 (setq overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
161 (if overlay |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
162 (if (overlay-get overlay 'end-glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
163 (progn |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
164 (overlay-put overlay 'end-glyph nil) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
165 (overlay-put overlay 'invisible nil)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
166 (overlay-put overlay 'end-glyph glyph) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
167 (overlay-put overlay 'invisible t))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
168 (t |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
169 (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
|
170 (overlays-at (point)))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
171 image) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
172 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
173 ;; Search overlay with an image. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
174 (while (and overlays (null image)) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
175 (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
|
176 (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
|
177 (setq image prop) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
178 (setq overlays (cdr overlays))))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
179 |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
180 ;; Toggle that overlay's image display. |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
181 (when overlays |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
182 (let ((overlay (car overlays))) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
183 (overlay-put overlay 'display |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
184 (if (overlay-get overlay 'display) |
afeb81bc23e6
(eudc-bob-play-sound-at-point): Play sounds
Gerd Moellmann <gerd@gnu.org>
parents:
27313
diff
changeset
|
185 nil image))))))))) |
27313 | 186 |
187 (defun eudc-bob-display-audio (data) | |
188 "Display a button for audio DATA." | |
189 (eudc-bob-make-button "[Audio Sound]" | |
190 eudc-bob-sound-keymap | |
191 eudc-bob-sound-menu | |
192 (list 'duplicable t | |
193 'start-open t | |
194 'end-open t | |
195 'object-data data))) | |
196 | |
197 (defun eudc-bob-display-generic-binary (data) | |
198 "Display a button for unidentified binary DATA." | |
199 (eudc-bob-make-button "[Binary Data]" | |
200 eudc-bob-generic-keymap | |
201 eudc-bob-generic-menu | |
202 (list 'duplicable t | |
203 'start-open t | |
204 'end-open t | |
205 'object-data data))) | |
206 | |
207 (defun eudc-bob-play-sound-at-point () | |
208 "Play the sound data contained in the button at point." | |
209 (interactive) | |
210 (let (sound) | |
211 (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) | |
212 (error "No sound data available here") | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
213 (unless (fboundp 'play-sound) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
214 (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
|
215 (play-sound (list 'sound :data sound))))) |
27313 | 216 |
217 (defun eudc-bob-play-sound-at-mouse (event) | |
218 "Play the sound data contained in the button where EVENT occurred." | |
219 (interactive "e") | |
220 (save-excursion | |
221 (eudc-jump-to-event event) | |
222 (eudc-bob-play-sound-at-point))) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
223 |
27313 | 224 (defun eudc-bob-save-object () |
225 "Save the object data of the button at point." | |
226 (interactive) | |
227 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
228 (buffer (generate-new-buffer "*eudc-tmp*"))) | |
229 (save-excursion | |
230 (if (fboundp 'set-buffer-file-coding-system) | |
231 (set-buffer-file-coding-system 'binary)) | |
232 (set-buffer buffer) | |
42554
bbfc062c0b51
(eudc-bob-can-display-inline-images)
Pavel Janík <Pavel@Janik.cz>
parents:
42519
diff
changeset
|
233 (set-buffer-multibyte nil) |
27313 | 234 (insert data) |
235 (save-buffer)) | |
236 (kill-buffer buffer))) | |
237 | |
238 (defun eudc-bob-pipe-object-to-external-program () | |
239 "Pipe the object data of the button at point to an external program." | |
240 (interactive) | |
241 (let ((data (eudc-bob-get-overlay-prop 'object-data)) | |
242 (buffer (generate-new-buffer "*eudc-tmp*")) | |
243 program | |
244 viewer) | |
245 (condition-case nil | |
246 (save-excursion | |
247 (if (fboundp 'set-buffer-file-coding-system) | |
248 (set-buffer-file-coding-system 'binary)) | |
249 (set-buffer buffer) | |
250 (insert data) | |
251 (setq program (completing-read "Viewer: " eudc-external-viewers)) | |
252 (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
|
253 (call-process-region (point-min) (point-max) |
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
254 (car (cdr viewer)) |
27313 | 255 (cdr (cdr viewer))) |
256 (call-process-region (point-min) (point-max) program))) | |
257 (t | |
258 (kill-buffer buffer))))) | |
259 | |
260 (defun eudc-bob-menu () | |
261 "Retrieve the menu attached to a binary object." | |
262 (eudc-bob-get-overlay-prop 'menu)) | |
42570
78a4068d960a
Remove unnecessary whitespaces.
Pavel Janík <Pavel@Janik.cz>
parents:
42554
diff
changeset
|
263 |
27313 | 264 (defun eudc-bob-popup-menu (event) |
265 "Pop-up a menu of EUDC multimedia commands." | |
266 (interactive "@e") | |
267 (run-hooks 'activate-menubar-hook) | |
268 (eudc-jump-to-event event) | |
269 (if eudc-xemacs-p | |
33516
92a7f3557095
(eudc-bob-can-display-inline-images): Use
Dave Love <fx@gnu.org>
parents:
27317
diff
changeset
|
270 (progn |
27313 | 271 (run-hooks 'activate-popup-menu-hook) |
272 (popup-menu (eudc-bob-menu))) | |
273 (let ((result (x-popup-menu t (eudc-bob-menu))) | |
274 command) | |
275 (if result | |
276 (progn | |
277 (setq command (lookup-key (eudc-bob-menu) | |
278 (apply 'vector result))) | |
279 (command-execute command)))))) | |
280 | |
281 (setq eudc-bob-generic-keymap | |
282 (let ((map (make-sparse-keymap))) | |
283 (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
|
284 (define-key map "!" 'eudc-bob-pipe-object-to-external-program) |
27313 | 285 (define-key map (if eudc-xemacs-p |
286 [button3] | |
287 [down-mouse-3]) 'eudc-bob-popup-menu) | |
288 map)) | |
289 | |
290 (setq eudc-bob-image-keymap | |
291 (let ((map (make-sparse-keymap))) | |
292 (define-key map "t" 'eudc-bob-toggle-inline-display) | |
293 map)) | |
294 | |
295 (setq eudc-bob-sound-keymap | |
296 (let ((map (make-sparse-keymap))) | |
297 (define-key map [return] 'eudc-bob-play-sound-at-point) | |
298 (define-key map (if eudc-xemacs-p | |
299 [button2] | |
300 [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) | |
301 map)) | |
302 | |
303 (setq eudc-bob-url-keymap | |
304 (let ((map (make-sparse-keymap))) | |
305 (define-key map [return] 'browse-url-at-point) | |
306 (define-key map (if eudc-xemacs-p | |
307 [button2] | |
308 [down-mouse-2]) 'browse-url-at-mouse) | |
309 map)) | |
310 | |
42775
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
311 (setq eudc-bob-mail-keymap |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
312 (let ((map (make-sparse-keymap))) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
313 (define-key map [return] 'goto-address-at-point) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
314 (define-key map (if eudc-xemacs-p |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
315 [button2] |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
316 [down-mouse-2]) 'goto-address-at-mouse) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
317 map)) |
c9c59300d7a6
New maintainer. Change author's address.
Pavel Janík <Pavel@Janik.cz>
parents:
42574
diff
changeset
|
318 |
27313 | 319 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) |
320 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) | |
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 | |
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 |
52401 | 369 ;;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3 |
27313 | 370 ;;; eudc-bob.el ends here |