lisp/net/eudc-bob.el

   1 ;;; eudc-bob.el --- Binary Objects Support for EUDC
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006 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.
 101 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
 102 LABEL."
 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.
 122 If INLINE is non-nil, try to inline the image otherwise simply
 123 display 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