1;;; eudc-bob.el --- Binary Objects Support for EUDC 2 3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Oscar Figueiredo <oscar@cpe.fr> 7;; Maintainer: Pavel Jan�k <Pavel@Janik.cz> 8;; Keywords: comm 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 14;; the Free Software Foundation; either version 2, or (at your option) 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 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 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 43 "Keymap for inline sounds.") 44 45(defvar eudc-bob-url-keymap nil 46 "Keymap for inline urls.") 47 48(defvar eudc-bob-mail-keymap nil 49 "Keymap for inline e-mail addresses.") 50 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)))) 63 64(defconst eudc-bob-sound-menu 65 `("EUDC Sound Menu" 66 ["---" nil nil] 67 ["Play sound" eudc-bob-play-sound-at-point 68 (fboundp 'play-sound)] 69 ,@(cdr (cdr eudc-bob-generic-menu)))) 70 71(defun eudc-jump-to-event (event) 72 "Jump to the window and point where EVENT occurred." 73 (if (fboundp 'event-closest-point) 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." 93 (if (fboundp 'console-type) 94 (and (memq (console-type) '(x mswindows)) 95 (fboundp 'make-glyph)) 96 (and (fboundp 'display-graphic-p) 97 (display-graphic-p)))) 98 99(defun eudc-bob-make-button (label keymap &optional menu plist) 100 "Create a button with LABEL. 101Attach KEYMAP, MENU and properties from PLIST to a new overlay covering 102LABEL." 103 (let (overlay 104 (p (point)) 105 prop val) 106 (insert label) 107 (put-text-property p (point) 'face 'bold) 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. 122If INLINE is non-nil, try to inline the image otherwise simply 123display a button." 124 (cond ((fboundp 'make-glyph) 125 (let ((glyph (if (eudc-bob-can-display-inline-images) 126 (make-glyph (list (vector 'jpeg :data data) 127 [string :data "[JPEG Picture]"]))))) 128 (eudc-bob-make-button "[JPEG Picture]" 129 eudc-bob-image-keymap 130 eudc-bob-image-menu 131 (list 'glyph glyph 132 'end-glyph (if inline glyph) 133 'duplicable t 134 'invisible inline 135 'start-open t 136 'end-open t 137 'object-data data)))) 138 ((fboundp 'create-image) 139 (let* ((image (create-image data nil t)) 140 (props (list 'object-data data 'eudc-image image))) 141 (when (and inline (image-type-available-p 'jpeg)) 142 (setq props (nconc (list 'display image) props))) 143 (eudc-bob-make-button "[Picture]" 144 eudc-bob-image-keymap 145 eudc-bob-image-menu 146 props))))) 147 148(defun eudc-bob-toggle-inline-display () 149 "Toggle inline display of an image." 150 (interactive) 151 (when (eudc-bob-can-display-inline-images) 152 (cond (eudc-xemacs-p 153 (let ((overlays (append (overlays-at (1- (point))) 154 (overlays-at (point)))) 155 overlay glyph) 156 (setq overlay (car overlays)) 157 (while (and overlay 158 (not (setq glyph (overlay-get overlay 'glyph)))) 159 (setq overlays (cdr overlays)) 160 (setq overlay (car overlays))) 161 (if overlay 162 (if (overlay-get overlay 'end-glyph) 163 (progn 164 (overlay-put overlay 'end-glyph nil) 165 (overlay-put overlay 'invisible nil)) 166 (overlay-put overlay 'end-glyph glyph) 167 (overlay-put overlay 'invisible t))))) 168 (t 169 (let* ((overlays (append (overlays-at (1- (point))) 170 (overlays-at (point)))) 171 image) 172 173 ;; Search overlay with an image. 174 (while (and overlays (null image)) 175 (let ((prop (overlay-get (car overlays) 'eudc-image))) 176 (if (eq 'image (car-safe prop)) 177 (setq image prop) 178 (setq overlays (cdr overlays))))) 179 180 ;; Toggle that overlay's image display. 181 (when overlays 182 (let ((overlay (car overlays))) 183 (overlay-put overlay 'display 184 (if (overlay-get overlay 'display) 185 nil image))))))))) 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") 213 (unless (fboundp 'play-sound) 214 (error "Playing sounds not supported on this system")) 215 (play-sound (list 'sound :data sound))))) 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))) 223 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) 233 (set-buffer-multibyte nil) 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)) 253 (call-process-region (point-min) (point-max) 254 (car (cdr viewer)) 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)) 263 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 270 (progn 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) 284 (define-key map "!" 'eudc-bob-pipe-object-to-external-program) 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 311(setq eudc-bob-mail-keymap 312 (let ((map (make-sparse-keymap))) 313 (define-key map [return] 'goto-address-at-point) 314 (define-key map (if eudc-xemacs-p 315 [button2] 316 [down-mouse-2]) 'goto-address-at-mouse) 317 map)) 318 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 324 (easy-menu-define eudc-bob-generic-menu 325 eudc-bob-generic-keymap 326 "" 327 eudc-bob-generic-menu) 328 (easy-menu-define eudc-bob-image-menu 329 eudc-bob-image-keymap 330 "" 331 eudc-bob-image-menu) 332 (easy-menu-define eudc-bob-sound-menu 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-mail (mail) 350 "Display e-mail address and make it clickable." 351 (require 'goto-addr) 352 (eudc-bob-make-button mail eudc-bob-mail-keymap)) 353 354;;;###autoload 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)) 368 369;;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3 370;;; eudc-bob.el ends here 371