;;; eudc-bob.el --- Binary Objects Support for EUDC
-;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1999, 2000, 2002, 2003, 2004,
+;; 2005, 2006 Free Software Foundation, Inc.
-;; Author: Oscar Figueiredo <oscar@xemacs.org>
-;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
-;; Keywords: help
+;; Author: Oscar Figueiredo <oscar@cpe.fr>
+;; Maintainer: Pavel JanÃk <Pavel@Janik.cz>
+;; Keywords: comm
;; This file is part of GNU Emacs.
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
;;; Usage:
;; See the corresponding info file
"Keymap for inline images.")
(defvar eudc-bob-sound-keymap nil
- "Keymap for inline images.")
+ "Keymap for inline sounds.")
(defvar eudc-bob-url-keymap nil
- "Keymap for inline images.")
+ "Keymap for inline urls.")
+
+(defvar eudc-bob-mail-keymap nil
+ "Keymap for inline e-mail addresses.")
(defconst eudc-bob-generic-menu
'("EUDC Binary Object Menu"
["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
+ ["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
+ (if (fboundp 'event-closest-point)
(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-can-display-inline-images ()
"Return non-nil if we can display images inline."
- (and eudc-xemacs-p
- (memq (console-type)
- '(x mswindows))
- (fboundp 'make-glyph)))
+ (if (fboundp 'console-type)
+ (and (memq (console-type) '(x mswindows))
+ (fboundp 'make-glyph))
+ (and (fboundp 'display-graphic-p)
+ (display-graphic-p))))
(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
+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)
+ (put-text-property p (point) 'face 'bold)
(setq overlay (make-overlay p (point)))
(overlay-put overlay 'mouse-face 'highlight)
(overlay-put overlay 'keymap keymap)
(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
+If INLINE is non-nil, try to inline the image otherwise simply
display a button."
- (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))))
+ (cond ((fboundp 'make-glyph)
+ (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))))
+ ((fboundp 'create-image)
+ (let* ((image (create-image data nil t))
+ (props (list 'object-data data 'eudc-image image)))
+ (when (and inline (image-type-available-p 'jpeg))
+ (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)
- (if (eudc-bob-can-display-inline-images)
- (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))))))
+ (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 (eq 'image (car-safe 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."
'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]"
(let (sound)
(if (null (setq sound (eudc-bob-get-overlay-prop 'object-data)))
(error "No sound data available here")
- (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))))))))
-
+ (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."
(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."
(if (fboundp 'set-buffer-file-coding-system)
(set-buffer-file-coding-system 'binary))
(set-buffer buffer)
+ (set-buffer-multibyte nil)
(insert data)
(save-buffer))
(kill-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))
+ (call-process-region (point-min) (point-max)
+ (car (cdr viewer))
(cdr (cdr viewer)))
(call-process-region (point-min) (point-max) program)))
(t
(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
+ (progn
(run-hooks 'activate-popup-menu-hook)
(popup-menu (eudc-bob-menu)))
(let ((result (x-popup-menu t (eudc-bob-menu)))
(setq eudc-bob-generic-keymap
(let ((map (make-sparse-keymap)))
(define-key map "s" 'eudc-bob-save-object)
+ (define-key map "!" 'eudc-bob-pipe-object-to-external-program)
(define-key map (if eudc-xemacs-p
[button3]
[down-mouse-3]) 'eudc-bob-popup-menu)
[down-mouse-2]) 'browse-url-at-mouse)
map))
+(setq eudc-bob-mail-keymap
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'goto-address-at-point)
+ (define-key map (if eudc-xemacs-p
+ [button2]
+ [down-mouse-2]) 'goto-address-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
+ (easy-menu-define eudc-bob-generic-menu
eudc-bob-generic-keymap
""
eudc-bob-generic-menu)
- (easy-menu-define eudc-bob-image-menu
+ (easy-menu-define eudc-bob-image-menu
eudc-bob-image-keymap
""
eudc-bob-image-menu)
- (easy-menu-define eudc-bob-sound-menu
+ (easy-menu-define eudc-bob-sound-menu
eudc-bob-sound-keymap
""
eudc-bob-sound-menu)))
(require 'browse-url)
(eudc-bob-make-button url eudc-bob-url-keymap))
+;;;###autoload
+(defun eudc-display-mail (mail)
+ "Display e-mail address and make it clickable."
+ (require 'goto-addr)
+ (eudc-bob-make-button mail eudc-bob-mail-keymap))
+
;;;###autoload
(defun eudc-display-sound (data)
"Display a button to play the sound DATA."
(defun eudc-display-jpeg-as-button (data)
"Display a button for the JPEG DATA."
(eudc-bob-display-jpeg data nil))
-
+
+;;; arch-tag: 8f1853df-c9b6-4c5a-bdb1-d94dbd651fb3
;;; eudc-bob.el ends here