code.delx.au - gnu-emacs/blob - lisp/net/eudc-bob.el

   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 ;;; Commentary:
  27
  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
  42   "Keymap for inline sounds.")
  43
  44 (defvar eudc-bob-url-keymap nil
  45   "Keymap for inline images.")
  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))))
  59
  60 (defconst eudc-bob-sound-menu
  61   `("EUDC Sound Menu"
  62     ["---" nil nil]
  63     ["Play sound" eudc-bob-play-sound-at-point
  64      (fboundp 'play-sound)]
  65     ,@(cdr (cdr eudc-bob-generic-menu))))
  66
  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."
  89   (if eudc-xemacs-p
  90       (and (memq (console-type) '(x mswindows))
  91            (fboundp 'make-glyph))
  92     (and (boundp 'display-graphic-p)
  93          (display-graphic-p))))
  94
  95 (defun eudc-bob-make-button (label keymap &optional menu plist)
  96   "Create a button with LABEL.
  97 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
  98 LABEL."
  99   (let (overlay
 100         (p (point))
 101         prop val)
 102     (insert label)
 103     (put-text-property p (point) 'face 'bold)
 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.
 118 If INLINE is non-nil, try to inline the image otherwise simply
 119 display a button."
 120   (cond (eudc-xemacs-p
 121          (let ((glyph (if (eudc-bob-can-display-inline-images)
 122                           (make-glyph (list (vector 'jpeg :data data)
 123                                             [string :data "[JPEG Picture]"])))))
 124            (eudc-bob-make-button "[JPEG Picture]"
 125                                  eudc-bob-image-keymap
 126                                  eudc-bob-image-menu
 127                                  (list 'glyph glyph
 128                                        'end-glyph (if inline glyph)
 129                                        'duplicable t
 130                                        'invisible inline
 131                                        'start-open t
 132                                        'end-open t
 133                                        'object-data data))))
 134         ((boundp 'create-image)
 135          (let* ((image (create-image data nil t))
 136                 (props (list 'object-data data 'eudc-image image)))
 137            (when (and inline (image-type-available-p 'jpeg))
 138              (setq props (nconc (list 'display image) props)))
 139            (eudc-bob-make-button "[Picture]"
 140                                  eudc-bob-image-keymap
 141                                  eudc-bob-image-menu
 142                                  props)))))
 143
 144 (defun eudc-bob-toggle-inline-display ()
 145   "Toggle inline display of an image."
 146   (interactive)
 147   (when (eudc-bob-can-display-inline-images)
 148     (cond (eudc-xemacs-p
 149            (let ((overlays (append (overlays-at (1- (point)))
 150                                    (overlays-at (point))))
 151                  overlay glyph)
 152              (setq overlay (car overlays))
 153              (while (and overlay
 154                          (not (setq glyph (overlay-get overlay 'glyph))))
 155                (setq overlays (cdr overlays))
 156                (setq overlay (car overlays)))
 157              (if overlay
 158                  (if (overlay-get overlay 'end-glyph)
 159                      (progn
 160                        (overlay-put overlay 'end-glyph nil)
 161                        (overlay-put overlay 'invisible nil))
 162                    (overlay-put overlay 'end-glyph glyph)
 163                    (overlay-put overlay 'invisible t)))))
 164           (t
 165            (let* ((overlays (append (overlays-at (1- (point)))
 166                                     (overlays-at (point))))
 167                   image)
 168
 169              ;; Search overlay with an image.
 170              (while (and overlays (null image))
 171                (let ((prop (overlay-get (car overlays) 'eudc-image)))
 172                  (if (eq 'image (car-safe prop))
 173                      (setq image prop)
 174                    (setq overlays (cdr overlays)))))
 175
 176              ;; Toggle that overlay's image display.
 177              (when overlays
 178                (let ((overlay (car overlays)))
 179                  (overlay-put overlay 'display
 180                               (if (overlay-get overlay 'display)
 181                                   nil image)))))))))
 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")
 209       (cond (eudc-xemacs-p
 210              (if (not (and (boundp 'sound-alist)
 211                            sound-alist))
 212                  (error "Don't know how to play sound on this Emacs version")
 213                (setq sound-alist
 214                      (cons (list 'eudc-sound
 215                                  :sound sound)
 216                            sound-alist))
 217                (condition-case nil
 218                    (play-sound 'eudc-sound)
 219                  (t
 220                   (setq sound-alist (cdr sound-alist))))))
 221             (t
 222              (unless (fboundp 'play-sound)
 223                (error "Playing sounds not supported on this system"))
 224              (play-sound (list 'sound :data sound)))))))
 225
 226
 227 (defun eudc-bob-play-sound-at-mouse (event)
 228   "Play the sound data contained in the button where EVENT occurred."
 229   (interactive "e")
 230   (save-excursion
 231     (eudc-jump-to-event event)
 232     (eudc-bob-play-sound-at-point)))
 233
 234
 235 (defun eudc-bob-save-object ()
 236   "Save the object data of the button at point."
 237   (interactive)
 238   (let ((data (eudc-bob-get-overlay-prop 'object-data))
 239         (buffer (generate-new-buffer "*eudc-tmp*")))
 240     (save-excursion
 241       (if (fboundp 'set-buffer-file-coding-system)
 242           (set-buffer-file-coding-system 'binary))
 243       (set-buffer buffer)
 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))
 263               (call-process-region (point-min) (point-max)
 264                                    (car (cdr viewer))
 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))
 273
 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
 280       (progn
 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)
 294         (define-key map (if eudc-xemacs-p
 295                             [button3]
 296                           [down-mouse-3]) 'eudc-bob-popup-menu)
 297         map))
 298
 299 (setq eudc-bob-image-keymap
 300       (let ((map (make-sparse-keymap)))
 301         (define-key map "t" 'eudc-bob-toggle-inline-display)
 302         map))
 303
 304 (setq eudc-bob-sound-keymap
 305       (let ((map (make-sparse-keymap)))
 306         (define-key map [return] 'eudc-bob-play-sound-at-point)
 307         (define-key map (if eudc-xemacs-p
 308                             [button2]
 309                           [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
 310         map))
 311
 312 (setq eudc-bob-url-keymap
 313       (let ((map (make-sparse-keymap)))
 314         (define-key map [return] 'browse-url-at-point)
 315         (define-key map (if eudc-xemacs-p
 316                             [button2]
 317                           [down-mouse-2]) 'browse-url-at-mouse)
 318         map))
 319
 320 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
 321 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
 322
 323
 324 (if eudc-emacs-p
 325     (progn
 326       (easy-menu-define eudc-bob-generic-menu
 327                         eudc-bob-generic-keymap
 328                         ""
 329                         eudc-bob-generic-menu)
 330       (easy-menu-define eudc-bob-image-menu
 331                         eudc-bob-image-keymap
 332                         ""
 333                         eudc-bob-image-menu)
 334       (easy-menu-define eudc-bob-sound-menu
 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))
 364
 365 ;;; eudc-bob.el ends here