lisp/net/eudc-bob.el

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