Mercurial > emacs
view lisp/net/eudc-bob.el @ 27930:62d83c24995e
(help-xref-button): Add help-echo arg.
(describe-function-1, describe-variable, help-make-xrefs): Use it.
author | Dave Love <fx@gnu.org> |
---|---|
date | Wed, 01 Mar 2000 19:05:57 +0000 |
parents | afeb81bc23e6 |
children | 92a7f3557095 |
line wrap: on
line source
;;; eudc-bob.el --- Binary Objects Support for EUDC ;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo <oscar@xemacs.org> ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org> ;; Keywords: help ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Usage: ;; See the corresponding info file ;;; Code: (require 'eudc) (defvar eudc-bob-generic-keymap nil "Keymap for multimedia objects.") (defvar eudc-bob-image-keymap nil "Keymap for inline images.") (defvar eudc-bob-sound-keymap nil "Keymap for inline sounds.") (defvar eudc-bob-url-keymap nil "Keymap for inline images.") (defconst eudc-bob-generic-menu '("EUDC Binary Object Menu" ["---" nil nil] ["Pipe to external program" eudc-bob-pipe-object-to-external-program t] ["Save object" eudc-bob-save-object t])) (defconst eudc-bob-image-menu `("EUDC Image Menu" ["---" nil nil] ["Toggle inline display" eudc-bob-toggle-inline-display (eudc-bob-can-display-inline-images)] ,@(cdr (cdr eudc-bob-generic-menu)))) (defconst eudc-bob-sound-menu `("EUDC Sound Menu" ["---" nil nil] ["Play sound" eudc-bob-play-sound-at-point (fboundp 'play-sound)] ,@(cdr (cdr eudc-bob-generic-menu)))) (defun eudc-jump-to-event (event) "Jump to the window and point where EVENT occurred." (if eudc-xemacs-p (goto-char (event-closest-point event)) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))))) (defun eudc-bob-get-overlay-prop (prop) "Get property PROP from one of the overlays around." (let ((overlays (append (overlays-at (1- (point))) (overlays-at (point)))) overlay value (notfound t)) (while (and notfound (setq overlay (car overlays))) (if (setq value (overlay-get overlay prop)) (setq notfound nil)) (setq overlays (cdr overlays))) value)) (defun eudc-bob-can-display-inline-images () "Return non-nil if we can display images inline." (if eudc-xemacs-p (and (memq (console-type) '(x mswindows)) (fboundp 'make-glyph)) (and (boundp 'image-types) (not (null images-types))))) (defun eudc-bob-make-button (label keymap &optional menu plist) "Create a button with LABEL. Attach KEYMAP, MENU and properties from PLIST to a new overlay covering LABEL." (let (overlay (p (point)) prop val) (insert label) (put-text-property p (point) 'face 'bold) (setq overlay (make-overlay p (point))) (overlay-put overlay 'mouse-face 'highlight) (overlay-put overlay 'keymap keymap) (overlay-put overlay 'local-map keymap) (overlay-put overlay 'menu menu) (while plist (setq prop (car plist) plist (cdr plist) val (car plist) plist (cdr plist)) (overlay-put overlay prop val)))) (defun eudc-bob-display-jpeg (data inline) "Display the JPEG DATA at point. If INLINE is non-nil, try to inline the image otherwise simply display a button." (cond (eudc-xemacs-p (let ((glyph (if (eudc-bob-can-display-inline-images) (make-glyph (list (vector 'jpeg :data data) [string :data "[JPEG Picture]"]))))) (eudc-bob-make-button "[JPEG Picture]" eudc-bob-image-keymap eudc-bob-image-menu (list 'glyph glyph 'end-glyph (if inline glyph) 'duplicable t 'invisible inline 'start-open t 'end-open t 'object-data data)))) (t (let* ((image (create-image data nil t)) (props (list 'object-data data 'eudc-image image))) (when inline (setq props (nconc (list 'display image) props))) (eudc-bob-make-button "[Picture]" eudc-bob-image-keymap eudc-bob-image-menu props))))) (defun eudc-bob-toggle-inline-display () "Toggle inline display of an image." (interactive) (when (eudc-bob-can-display-inline-images) (cond (eudc-xemacs-p (let ((overlays (append (overlays-at (1- (point))) (overlays-at (point)))) overlay glyph) (setq overlay (car overlays)) (while (and overlay (not (setq glyph (overlay-get overlay 'glyph)))) (setq overlays (cdr overlays)) (setq overlay (car overlays))) (if overlay (if (overlay-get overlay 'end-glyph) (progn (overlay-put overlay 'end-glyph nil) (overlay-put overlay 'invisible nil)) (overlay-put overlay 'end-glyph glyph) (overlay-put overlay 'invisible t))))) (t (let* ((overlays (append (overlays-at (1- (point))) (overlays-at (point)))) image) ;; Search overlay with an image. (while (and overlays (null image)) (let ((prop (overlay-get (car overlays) 'eudc-image))) (if (imagep prop) (setq image prop) (setq overlays (cdr overlays))))) ;; Toggle that overlay's image display. (when overlays (let ((overlay (car overlays))) (overlay-put overlay 'display (if (overlay-get overlay 'display) nil image))))))))) (defun eudc-bob-display-audio (data) "Display a button for audio DATA." (eudc-bob-make-button "[Audio Sound]" eudc-bob-sound-keymap eudc-bob-sound-menu (list 'duplicable t 'start-open t 'end-open t 'object-data data))) (defun eudc-bob-display-generic-binary (data) "Display a button for unidentified binary DATA." (eudc-bob-make-button "[Binary Data]" eudc-bob-generic-keymap eudc-bob-generic-menu (list 'duplicable t 'start-open t 'end-open t 'object-data data))) (defun eudc-bob-play-sound-at-point () "Play the sound data contained in the button at point." (interactive) (let (sound) (if (null (setq sound (eudc-bob-get-overlay-prop 'object-data))) (error "No sound data available here") (cond (eudc-xemacs-p (if (not (and (boundp 'sound-alist) sound-alist)) (error "Don't know how to play sound on this Emacs version") (setq sound-alist (cons (list 'eudc-sound :sound sound) sound-alist)) (condition-case nil (play-sound 'eudc-sound) (t (setq sound-alist (cdr sound-alist)))))) (t (unless (fboundp 'play-sound) (error "Playing sounds not supported on this system")) (play-sound (list 'sound :data sound))))))) (defun eudc-bob-play-sound-at-mouse (event) "Play the sound data contained in the button where EVENT occurred." (interactive "e") (save-excursion (eudc-jump-to-event event) (eudc-bob-play-sound-at-point))) (defun eudc-bob-save-object () "Save the object data of the button at point." (interactive) (let ((data (eudc-bob-get-overlay-prop 'object-data)) (buffer (generate-new-buffer "*eudc-tmp*"))) (save-excursion (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system 'binary)) (set-buffer buffer) (insert data) (save-buffer)) (kill-buffer buffer))) (defun eudc-bob-pipe-object-to-external-program () "Pipe the object data of the button at point to an external program." (interactive) (let ((data (eudc-bob-get-overlay-prop 'object-data)) (buffer (generate-new-buffer "*eudc-tmp*")) program viewer) (condition-case nil (save-excursion (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system 'binary)) (set-buffer buffer) (insert data) (setq program (completing-read "Viewer: " eudc-external-viewers)) (if (setq viewer (assoc program eudc-external-viewers)) (call-process-region (point-min) (point-max) (car (cdr viewer)) (cdr (cdr viewer))) (call-process-region (point-min) (point-max) program))) (t (kill-buffer buffer))))) (defun eudc-bob-menu () "Retrieve the menu attached to a binary object." (eudc-bob-get-overlay-prop 'menu)) (defun eudc-bob-popup-menu (event) "Pop-up a menu of EUDC multimedia commands." (interactive "@e") (run-hooks 'activate-menubar-hook) (eudc-jump-to-event event) (if eudc-xemacs-p (progn (run-hooks 'activate-popup-menu-hook) (popup-menu (eudc-bob-menu))) (let ((result (x-popup-menu t (eudc-bob-menu))) command) (if result (progn (setq command (lookup-key (eudc-bob-menu) (apply 'vector result))) (command-execute command)))))) (setq eudc-bob-generic-keymap (let ((map (make-sparse-keymap))) (define-key map "s" 'eudc-bob-save-object) (define-key map (if eudc-xemacs-p [button3] [down-mouse-3]) 'eudc-bob-popup-menu) map)) (setq eudc-bob-image-keymap (let ((map (make-sparse-keymap))) (define-key map "t" 'eudc-bob-toggle-inline-display) map)) (setq eudc-bob-sound-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'eudc-bob-play-sound-at-point) (define-key map (if eudc-xemacs-p [button2] [down-mouse-2]) 'eudc-bob-play-sound-at-mouse) map)) (setq eudc-bob-url-keymap (let ((map (make-sparse-keymap))) (define-key map [return] 'browse-url-at-point) (define-key map (if eudc-xemacs-p [button2] [down-mouse-2]) 'browse-url-at-mouse) map)) (set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) (set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) (if eudc-emacs-p (progn (easy-menu-define eudc-bob-generic-menu eudc-bob-generic-keymap "" eudc-bob-generic-menu) (easy-menu-define eudc-bob-image-menu eudc-bob-image-keymap "" eudc-bob-image-menu) (easy-menu-define eudc-bob-sound-menu eudc-bob-sound-keymap "" eudc-bob-sound-menu))) ;;;###autoload (defun eudc-display-generic-binary (data) "Display a button for unidentified binary DATA." (eudc-bob-display-generic-binary data)) ;;;###autoload (defun eudc-display-url (url) "Display URL and make it clickable." (require 'browse-url) (eudc-bob-make-button url eudc-bob-url-keymap)) ;;;###autoload (defun eudc-display-sound (data) "Display a button to play the sound DATA." (eudc-bob-display-audio data)) ;;;###autoload (defun eudc-display-jpeg-inline (data) "Display the JPEG DATA inline at point if possible." (eudc-bob-display-jpeg data (eudc-bob-can-display-inline-images))) ;;;###autoload (defun eudc-display-jpeg-as-button (data) "Display a button for the JPEG DATA." (eudc-bob-display-jpeg data nil)) ;;; eudc-bob.el ends here