lisp/net/eudc-bob.el

   1 ;;; eudc-bob.el --- Binary Objects Support for EUDC -*- coding: utf-8 -*-
   2
   3 ;; Copyright (C) 1999-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@cpe.fr>
   6 ;; Maintainer: Pavel Janík <Pavel@Janik.cz>
   7 ;; Keywords: comm
   8 ;; Package: eudc
   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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;; Usage:
  28 ;;    See the corresponding info file
  29
  30 ;;; Code:
  31
  32 (require 'eudc)
  33
  34 (defvar eudc-bob-generic-keymap nil
  35   "Keymap for multimedia objects.")
  36
  37 (defvar eudc-bob-image-keymap nil
  38   "Keymap for inline images.")
  39
  40 (defvar eudc-bob-sound-keymap nil
  41   "Keymap for inline sounds.")
  42
  43 (defvar eudc-bob-url-keymap nil
  44   "Keymap for inline urls.")
  45
  46 (defvar eudc-bob-mail-keymap nil
  47   "Keymap for inline e-mail addresses.")
  48
  49 (defvar eudc-bob-generic-menu
  50   '("EUDC Binary Object Menu"
  51     ["---" nil nil]
  52     ["Pipe to external program" eudc-bob-pipe-object-to-external-program t]
  53     ["Save object" eudc-bob-save-object t]))
  54
  55 (defvar eudc-bob-image-menu
  56   `("EUDC Image Menu"
  57     ["---" nil nil]
  58     ["Toggle inline display" eudc-bob-toggle-inline-display
  59      (eudc-bob-can-display-inline-images)]
  60     ,@(cdr (cdr eudc-bob-generic-menu))))
  61
  62 (defvar eudc-bob-sound-menu
  63   `("EUDC Sound Menu"
  64     ["---" nil nil]
  65     ["Play sound" eudc-bob-play-sound-at-point
  66      (fboundp 'play-sound)]
  67     ,@(cdr (cdr eudc-bob-generic-menu))))
  68
  69 (defun eudc-jump-to-event (event)
  70   "Jump to the window and point where EVENT occurred."
  71   (if (fboundp 'event-closest-point)
  72       (goto-char (event-closest-point event))
  73     (set-buffer (window-buffer (posn-window (event-start event))))
  74     (goto-char (posn-point (event-start event)))))
  75
  76 (defun eudc-bob-get-overlay-prop (prop)
  77   "Get property PROP from one of the overlays around."
  78   (let ((overlays (append (overlays-at (1- (point)))
  79                           (overlays-at (point))))
  80         overlay value
  81         (notfound t))
  82     (while (and notfound
  83                 (setq overlay (car overlays)))
  84       (if (setq value (overlay-get overlay prop))
  85           (setq notfound nil))
  86       (setq overlays (cdr overlays)))
  87     value))
  88
  89 (defun eudc-bob-can-display-inline-images ()
  90   "Return non-nil if we can display images inline."
  91   (if (fboundp 'console-type)
  92       (and (memq (console-type) '(x mswindows))
  93            (fboundp 'make-glyph))
  94     (and (fboundp 'display-graphic-p)
  95          (display-graphic-p))))
  96
  97 (defun eudc-bob-make-button (label keymap &optional menu plist)
  98   "Create a button with LABEL.
  99 Attach KEYMAP, MENU and properties from PLIST to a new overlay covering
 100 LABEL."
 101   (let (overlay
 102         (p (point))
 103         prop val)
 104     (insert label)
 105     (put-text-property p (point) 'face 'bold)
 106     (setq overlay (make-overlay p (point)))
 107     (overlay-put overlay 'mouse-face 'highlight)
 108     (overlay-put overlay 'keymap keymap)
 109     (overlay-put overlay 'local-map keymap)
 110     (overlay-put overlay 'menu menu)
 111     (while plist
 112       (setq prop (car plist)
 113             plist (cdr plist)
 114             val (car plist)
 115             plist (cdr plist))
 116       (overlay-put overlay prop val))))
 117
 118 (defun eudc-bob-display-jpeg (data inline)
 119   "Display the JPEG DATA at point.
 120 If INLINE is non-nil, try to inline the image otherwise simply
 121 display a button."
 122   (cond ((fboundp 'make-glyph)
 123          (let ((glyph (if (eudc-bob-can-display-inline-images)
 124                           (make-glyph (list (vector 'jpeg :data data)
 125                                             [string :data "[JPEG Picture]"])))))
 126            (eudc-bob-make-button "[JPEG Picture]"
 127                                  eudc-bob-image-keymap
 128                                  eudc-bob-image-menu
 129                                  (list 'glyph glyph
 130                                        'end-glyph (if inline glyph)
 131                                        'duplicable t
 132                                        'invisible inline
 133                                        'start-open t
 134                                        'end-open t
 135                                        'object-data data))))
 136         ((fboundp 'create-image)
 137          (let* ((image (create-image data nil t))
 138                 (props (list 'object-data data 'eudc-image image)))
 139            (when (and inline (image-type-available-p 'jpeg))
 140              (setq props (nconc (list 'display image) props)))
 141            (eudc-bob-make-button "[Picture]"
 142                                  eudc-bob-image-keymap
 143                                  eudc-bob-image-menu
 144                                  props)))))
 145
 146 (defun eudc-bob-toggle-inline-display ()
 147   "Toggle inline display of an image."
 148   (interactive)
 149   (when (eudc-bob-can-display-inline-images)
 150     (cond ((featurep 'xemacs)
 151            (let ((overlays (append (overlays-at (1- (point)))
 152                                    (overlays-at (point))))
 153                  overlay glyph)
 154              (setq overlay (car overlays))
 155              (while (and overlay
 156                          (not (setq glyph (overlay-get overlay 'glyph))))
 157                (setq overlays (cdr overlays))
 158                (setq overlay (car overlays)))
 159              (if overlay
 160                  (if (overlay-get overlay 'end-glyph)
 161                      (progn
 162                        (overlay-put overlay 'end-glyph nil)
 163                        (overlay-put overlay 'invisible nil))
 164                    (overlay-put overlay 'end-glyph glyph)
 165                    (overlay-put overlay 'invisible t)))))
 166           (t
 167            (let* ((overlays (append (overlays-at (1- (point)))
 168                                     (overlays-at (point))))
 169                   image)
 170
 171              ;; Search overlay with an image.
 172              (while (and overlays (null image))
 173                (let ((prop (overlay-get (car overlays) 'eudc-image)))
 174                  (if (eq 'image (car-safe prop))
 175                      (setq image prop)
 176                    (setq overlays (cdr overlays)))))
 177
 178              ;; Toggle that overlay's image display.
 179              (when overlays
 180                (let ((overlay (car overlays)))
 181                  (overlay-put overlay 'display
 182                               (if (overlay-get overlay 'display)
 183                                   nil image)))))))))
 184
 185 (defun eudc-bob-display-audio (data)
 186   "Display a button for audio DATA."
 187   (eudc-bob-make-button "[Audio Sound]"
 188                         eudc-bob-sound-keymap
 189                         eudc-bob-sound-menu
 190                         (list 'duplicable t
 191                               'start-open t
 192                               'end-open t
 193                               'object-data data)))
 194
 195 (defun eudc-bob-display-generic-binary (data)
 196   "Display a button for unidentified binary DATA."
 197   (eudc-bob-make-button "[Binary Data]"
 198                         eudc-bob-generic-keymap
 199                         eudc-bob-generic-menu
 200                         (list 'duplicable t
 201                               'start-open t
 202                               'end-open t
 203                               'object-data data)))
 204
 205 (defun eudc-bob-play-sound-at-point ()
 206   "Play the sound data contained in the button at point."
 207   (interactive)
 208   (let (sound)
 209     (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
 210         (error "No sound data available here")
 211       (unless (fboundp 'play-sound)
 212         (error "Playing sounds not supported on this system"))
 213       (play-sound (list 'sound :data sound)))))
 214
 215 (defun eudc-bob-play-sound-at-mouse (event)
 216   "Play the sound data contained in the button where EVENT occurred."
 217   (interactive "e")
 218   (save-excursion
 219     (eudc-jump-to-event event)
 220     (eudc-bob-play-sound-at-point)))
 221
 222 (defun eudc-bob-save-object ()
 223   "Save the object data of the button at point."
 224   (interactive)
 225   (let ((data (eudc-bob-get-overlay-prop 'object-data))
 226         (buffer (generate-new-buffer "*eudc-tmp*")))
 227     (save-excursion
 228       (if (fboundp 'set-buffer-file-coding-system)
 229           (set-buffer-file-coding-system 'binary))
 230       (set-buffer buffer)
 231       (set-buffer-multibyte nil)
 232       (insert data)
 233       (save-buffer))
 234     (kill-buffer buffer)))
 235
 236 (defun eudc-bob-pipe-object-to-external-program ()
 237   "Pipe the object data of the button at point to an external program."
 238   (interactive)
 239   (let ((data (eudc-bob-get-overlay-prop 'object-data))
 240         (buffer (generate-new-buffer "*eudc-tmp*"))
 241         program
 242         viewer)
 243     (condition-case nil
 244         (save-excursion
 245           (if (fboundp 'set-buffer-file-coding-system)
 246               (set-buffer-file-coding-system 'binary))
 247           (set-buffer buffer)
 248           (insert data)
 249           (setq program (completing-read "Viewer: " eudc-external-viewers))
 250           (if (setq viewer (assoc program eudc-external-viewers))
 251               (call-process-region (point-min) (point-max)
 252                                    (car (cdr viewer))
 253                                    (cdr (cdr viewer)))
 254             (call-process-region (point-min) (point-max) program)))
 255       (error
 256        (kill-buffer buffer)))))
 257
 258 (defun eudc-bob-menu ()
 259   "Retrieve the menu attached to a binary object."
 260   (eudc-bob-get-overlay-prop 'menu))
 261
 262 (defun eudc-bob-popup-menu (event)
 263   "Pop-up a menu of EUDC multimedia commands."
 264   (interactive "@e")
 265   (run-hooks 'activate-menubar-hook)
 266   (eudc-jump-to-event event)
 267   (if (featurep 'xemacs)
 268       (progn
 269         (run-hooks 'activate-popup-menu-hook)
 270         (popup-menu (eudc-bob-menu)))
 271     (let ((result (x-popup-menu t (eudc-bob-menu)))
 272           command)
 273       (if result
 274           (progn
 275             (setq command (lookup-key (eudc-bob-menu)
 276                                       (apply 'vector result)))
 277             (command-execute command))))))
 278
 279 (setq eudc-bob-generic-keymap
 280       (let ((map (make-sparse-keymap)))
 281         (define-key map "s" 'eudc-bob-save-object)
 282         (define-key map "!" 'eudc-bob-pipe-object-to-external-program)
 283         (define-key map (if (featurep 'xemacs)
 284                             [button3]
 285                           [down-mouse-3]) 'eudc-bob-popup-menu)
 286         map))
 287
 288 (setq eudc-bob-image-keymap
 289       (let ((map (make-sparse-keymap)))
 290         (define-key map "t" 'eudc-bob-toggle-inline-display)
 291         map))
 292
 293 (setq eudc-bob-sound-keymap
 294       (let ((map (make-sparse-keymap)))
 295         (define-key map [return] 'eudc-bob-play-sound-at-point)
 296         (define-key map (if (featurep 'xemacs)
 297                             [button2]
 298                           [down-mouse-2]) 'eudc-bob-play-sound-at-mouse)
 299         map))
 300
 301 (setq eudc-bob-url-keymap
 302       (let ((map (make-sparse-keymap)))
 303         (define-key map [return] 'browse-url-at-point)
 304         (define-key map (if (featurep 'xemacs)
 305                             [button2]
 306                           [down-mouse-2]) 'browse-url-at-mouse)
 307         map))
 308
 309 (setq eudc-bob-mail-keymap
 310       (let ((map (make-sparse-keymap)))
 311         (define-key map [return] 'goto-address-at-point)
 312         (define-key map (if (featurep 'xemacs)
 313                             [button2]
 314                           [down-mouse-2]) 'goto-address-at-mouse)
 315         map))
 316
 317 (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap)
 318 (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap)
 319
 320 ;; If the first arguments can be nil here, then these 3 can be
 321 ;; defconsts once more.
 322 (when (not (featurep 'xemacs))
 323   (easy-menu-define eudc-bob-generic-menu
 324     eudc-bob-generic-keymap
 325     ""
 326     eudc-bob-generic-menu)
 327   (easy-menu-define eudc-bob-image-menu
 328     eudc-bob-image-keymap
 329     ""
 330     eudc-bob-image-menu)
 331   (easy-menu-define eudc-bob-sound-menu
 332     eudc-bob-sound-keymap
 333     ""
 334     eudc-bob-sound-menu))
 335
 336 ;;;###autoload
 337 (defun eudc-display-generic-binary (data)
 338   "Display a button for unidentified binary DATA."
 339   (eudc-bob-display-generic-binary data))
 340
 341 ;;;###autoload
 342 (defun eudc-display-url (url)
 343   "Display URL and make it clickable."
 344   (require 'browse-url)
 345   (eudc-bob-make-button url eudc-bob-url-keymap))
 346
 347 ;;;###autoload
 348 (defun eudc-display-mail (mail)
 349   "Display e-mail address and make it clickable."
 350   (require 'goto-addr)
 351   (eudc-bob-make-button mail eudc-bob-mail-keymap))
 352
 353 ;;;###autoload
 354 (defun eudc-display-sound (data)
 355   "Display a button to play the sound DATA."
 356   (eudc-bob-display-audio data))
 357
 358 ;;;###autoload
 359 (defun eudc-display-jpeg-inline (data)
 360   "Display the JPEG DATA inline at point if possible."
 361   (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images)))
 362
 363 ;;;###autoload
 364 (defun eudc-display-jpeg-as-button (data)
 365   "Display a button for the JPEG DATA."
 366   (eudc-bob-display-jpeg data nil))
 367
 368 ;;; eudc-bob.el ends here