xemacs-beta: lisp/utils/annotations.el comparison

comparison lisp/utils/annotations.el @ 0:376386a54a3c r19-14

Import from CVS: tag r19-14

author	cvs
date	Mon, 13 Aug 2007 08:45:50 +0200
parents
children	0293115a14e9

comparison

equal deleted inserted replaced

--1:000000000000
+:376386a54a3c
+;;; annotations.el --- interface to marginal annotations
+;; Copyright (C) 1992-1994 Free Software Foundation, Inc.
+;;
+;; Created: 10-Oct-93, Chuck Thompson <cthomp@cs.uiuc.edu>
+;; Keywords: extensions, hypermedia, outlining
+;; Enhanced by Andy Piper <ajp@eng.cam.ac.uk>: 6-may-94
+;;
+;; Last modified:  12-May-95 by Chuck Thompson.
+;; This file is part of XEmacs.
+;; XEmacs 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.
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Synched up with: Not in FSF.
+;;
+;; The annotations are implemented on top of extents.  The extent property
+;; 'annotation of an extent being used as an annotation is vector of size 6:
+;;	[<data> <action> <menu> <glyph> <down-glyph> <rightp>]
+;;
+;;;###autoload
+(defvar make-annotation-hook nil
+"*Function or functions to run immediately after creating an annotation.")
+;;;###autoload
+(defvar before-delete-annotation-hook nil
+"*Function or functions to run immediately before deleting an annotation.")
+;;;###autoload
+(defvar after-delete-annotation-hook nil
+"*Function or functions to run immediately after deleting an annotation.")
+(defvar annotation-local-map-default
+(let ((map (make-sparse-keymap)))
+(set-keymap-name map 'annotation-local-map)
+(define-key map 'button1 'annotation-activate-function-default)
+(define-key map 'button3 'annotation-popup-menu)
+map)
+"Keymap used to activate annotations with only annotation data passed.")
+(defvar annotation-local-map-with-event
+(let ((map (make-sparse-keymap)))
+(set-keymap-name map 'annotation-local-map)
+(define-key map 'button1 'annotation-activate-function-with-event)
+(define-key map 'button3 'annotation-popup-menu)
+map)
+"Keymap used to activate annotations with annotation data and event passed.")
+;;
+;; When the mouse is pressed and released over an annotation glyph
+;; this will run the annotation action passing a single arg, the value
+;; of the annotation data field.
+;;
+(defun annotation-activate-function-default (event)
+(interactive "e")
+(let ((extent (event-glyph-extent event))
+	(mouse-down t)
+	(up-glyph nil))
+;; make the glyph look pressed
+(cond ((annotation-down-glyph extent)
+	   (setq up-glyph (annotation-glyph extent))
+	   (set-annotation-glyph extent (annotation-down-glyph extent))))
+(while mouse-down
+(setq event (next-event event))
+(if (button-release-event-p event)
+	  (setq mouse-down nil)))
+;; make the glyph look released
+(cond ((annotation-down-glyph extent)
+	   (set-annotation-glyph extent up-glyph)))
+(if (eq extent (event-glyph-extent event))
+	(if (annotation-action extent)
+	    (funcall (annotation-action extent) (annotation-data extent))))))
+;;
+;; When the mouse is pressed and released over an annotation glyph
+;; this will run the annotation action passing two args, the value
+;; of the annotation data field and the event which triggered the
+;; annotation.
+;;
+(defun annotation-activate-function-with-event (event)
+(interactive "e")
+(let ((extent (event-glyph-extent event))
+	(mouse-down t)
+	(up-glyph nil))
+;; make the glyph look pressed
+(cond ((annotation-down-glyph extent)
+	   (setq up-glyph (annotation-glyph extent))
+	   (set-annotation-glyph extent (annotation-down-glyph extent))))
+(while mouse-down
+(setq event (next-event event))
+(if (button-release-event-p event)
+	  (setq mouse-down nil)))
+;; make the glyph look released
+(cond ((annotation-down-glyph extent)
+	   (set-annotation-glyph extent up-glyph)))
+(if (eq extent (event-glyph-extent event))
+	(if (annotation-action extent)
+	    (funcall (annotation-action extent) (annotation-data extent)
+		     event)))))
+;; #### Glyphs should be glyphs should be glyphs
+;;;###autoload
+(defun make-annotation (glyph &optional pos layout buffer with-event d-glyph rightp)
+"Create a marginal annotation, displayed using GLYPH, at position POS.
+GLYPH may be either a glyph object or a string.  Use layout policy
+LAYOUT and place the annotation in buffer BUFFER.  If POS is nil, point is
+used.  If LAYOUT is nil, `whitespace' is used.  If BUFFER is nil, the
+current buffer is used.  If WITH-EVENT is non-nil, then when an annotation
+is activated, the triggering event is passed as the second arg to the
+annotation function.  If D-GLYPH is non-nil then it is used as the glyph
+that will be displayed when button1 is down.  If RIGHTP is non-nil then
+the glyph will be displayed on the right side of the buffer instead of the
+left."
+(let ((new-annotation))
+;; get the buffer to add the annotation at
+(if (not buffer)
+	(setq buffer (current-buffer))
+(setq buffer (get-buffer buffer)))
+;; get the position to put it at
+(if (not pos)
+	(save-excursion
+	  (set-buffer buffer)
+	  (setq pos (point))))
+;; make sure it gets some layout policy
+(if (not layout)
+	(setq layout 'whitespace))
+;; make sure the glyph arguments are actually glyphs
+(if (and glyph (not (glyphp glyph)))
+	(setq glyph (make-glyph glyph)))
+(if (and d-glyph (not (glyphp d-glyph)))
+	(setq d-glyph (make-glyph d-glyph)))
+;; create the actual annotation
+(setq new-annotation (make-extent pos pos buffer))
+(detach-extent new-annotation)
+(set-extent-endpoints new-annotation pos pos)
+(if rightp
+	(set-extent-end-glyph new-annotation glyph layout)
+(set-extent-begin-glyph new-annotation glyph layout))
+(set-extent-property new-annotation 'annotation
+			 (vector nil nil nil glyph d-glyph rightp))
+(set-extent-property new-annotation 'end-closed t)
+(set-extent-property new-annotation 'start-open t)
+(set-extent-property new-annotation 'duplicable t)
+(if with-event
+	(set-extent-property new-annotation 'keymap
+			     annotation-local-map-with-event)
+(set-extent-property new-annotation 'keymap
+			   annotation-local-map-default))
+(run-hook-with-args 'make-annotation-hook new-annotation)
+new-annotation))
+(fset 'make-graphic-annotation 'make-annotation)
+(make-obsolete 'make-graphic-annotation 'make-annotation)
+;;;###autoload
+(defun delete-annotation (annotation)
+"Remove ANNOTATION from its buffer.  This does not modify the buffer text."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(progn
+(run-hook-with-args 'before-delete-annotation-hook annotation)
+(delete-extent annotation)
+(run-hooks 'after-delete-annotation-hook))))
+;;;###autoload
+(defun annotationp (annotation)
+"T if OBJECT is an annotation."
+(and (extent-live-p annotation)
+(not (null (extent-property annotation 'annotation)))))
+(defun annotation-visible (annotation)
+"T if there is enough available space to display ANNOTATION."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(not (extent-property annotation 'glyph-invisible))))
+;;;###autoload
+(defun annotation-at (&optional pos buffer)
+"Return the first annotation at POS in BUFFER.
+BUFFER defaults to the current buffer.  POS defaults to point in BUFFER."
+(car (annotations-at pos buffer)))
+(make-obsolete 'annotation-at 'annotations-at)
+(defun annotation-layout (annotation)
+"Return the layout policy of annotation ANNOTATION.  The layout policy
+is set using `set-annotation-layout'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(if (eq 'right (annotation-side annotation))
+	(extent-end-glyph-layout annotation)
+(extent-begin-glyph-layout annotation))))
+(defun annotation-side (annotation)
+"Return the side of the buffer the annotation is displayed on.
+Return value is either 'left or 'right."
+(if (aref (extent-property annotation 'annotation) 5)
+'right
+'left))
+(defun set-annotation-layout (annotation layout)
+"Set the layout policy of ANNOTATION to LAYOUT.  The function
+`annotation-layout' returns the current layout policy."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(if (eq 'right (annotation-side annotation))
+	(set-extent-end-glyph-layout annotation layout)
+(set-extent-begin-glyph-layout annotation layout))))
+;; Now that annotatios use glyphs this function has little value and
+;; will actually not work as is.
+;(defun annotation-type (annotation)
+;  "Return the display type of the annotation ANNOTATION.  The type will
+;be one of the following symbols:
+;
+;	pixmap
+;	bitmap
+;	string
+;	nil	(the object is not an annotation)"
+;  (if (not (annotationp annotation))
+;      nil
+;    (let ((glyph (annotation-glyph annotation)))
+;      (if (stringp glyph)
+;	  'stringp
+;	(if (not (pixmapp glyph))
+;	    (error "%s is a corrupt annotation" annotation)
+;	  (if (> (pixmap-depth glyph) 0)
+;	      'pixmap
+;	    'bitmap))))))
+(make-obsolete 'annotation-type "This function no longer has any meaning.")
+(defun annotation-width (annotation)
+"Return the width of the annotation ANNOTATION in pixels."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(glyph-width (annotation-glyph annotation))))
+(defun annotation-glyph (annotation)
+"If ANNOTATION is of type `string' return the string.  Otherwise, return
+the glyph object used to display ANNOTATION.  The glyph is set using
+`set-annotation-glyph'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aref (extent-property annotation 'annotation) 3)))
+(defun set-annotation-glyph (annotation glyph &optional layout side)
+"Set the representation of ANNOTATION to GLYPH.
+GLYPH should be a glyph object.  If LAYOUT is non-nil, set the layout
+policy of the annotation to LAYOUT.  If SIDE is equal to 'left or 'right
+change the side of the annotation to that value.
+The function `annotation-glyph' returns the current glyph."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(progn
+(if (not layout)
+	  (setq layout (extent-layout annotation)))
+(if (or (eq side 'right)
+	      (and (not (eq side 'left))
+		   (eq (annotation-side annotation) 'right)))
+	  (set-extent-end-glyph annotation glyph layout)
+	(set-extent-begin-glyph annotation glyph layout))
+(aset (extent-property annotation 'annotation) 3 glyph)
+(if (eq side 'right)
+	  (aset (extent-property annotation 'annotation) 5 t))
+(if (eq side 'left)
+	  (aset (extent-property annotation 'annotation) 5 nil))
+(annotation-glyph annotation))))
+(defun annotation-down-glyph (annotation)
+"If ANNOTATION is of type `string' return the down string.  Otherwise,
+return the glyph object of the down-glyph representing ANNOTATION.
+The down-glyph is set using `set-annotation-down-glyph'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aref (extent-property annotation 'annotation) 4)))
+(defun set-annotation-down-glyph (annotation glyph)
+"Set the depressed representation of ANNOTATION to GLYPH.
+GLYPH should be a glyph object.
+The function `annotation-down-glyph' returns the current down-glyph."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aset (extent-property annotation 'annotation) 4 glyph)))
+(define-obsolete-function-alias 'annotation-graphic 'annotation-glyph)
+(define-obsolete-function-alias 'set-annotation-graphic 'set-annotation-glyph)
+(defun annotation-data (annotation)
+"Return the data associated with annotation ANNOTATION.  The data is
+set using `set-annotation-data'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aref (extent-property annotation 'annotation) 0)))
+(defun set-annotation-data (annotation data)
+"Set the data field of ANNOTATION to DATA.
+The function `annotation-data' returns the current data."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aset (extent-property annotation 'annotation) 0 data)))
+(defun annotation-action (annotation)
+"Return the action associated with annotation ANNOTATION.  The action
+is set using `set-annotation-action'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aref (extent-property annotation 'annotation) 1)))
+(defun set-annotation-action (annotation action)
+"Set the action field of ANNOTATION to ACTION.
+The function `annotation-action' returns the current action."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aset (extent-property annotation 'annotation) 1 action)))
+(defun annotation-face (annotation)
+"Return the face associated with annotation ANNOTATION.
+The face is set using `set-annotation-face'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(extent-face annotation)))
+(defun set-annotation-face (annotation face)
+"Set the face associated with annotation ANNOTATION to FACE.
+The function `annotation-face' returns the current face."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(set-extent-face annotation face)))
+(defun hide-annotation (annotation)
+"Remove ANNOTATION's glyph so that it is invisible."
+(if (eq (annotation-side annotation) 'left)
+(set-extent-begin-glyph annotation nil)
+(set-extent-end-glyph annotation nil)))
+(define-obsolete-function-alias 'annotation-hide 'hide-annotation)
+(defun reveal-annotation (annotation)
+"Add ANNOTATION's glyph so that it is visible."
+(if (eq (annotation-side annotation) 'left)
+(set-extent-begin-glyph annotation (annotation-glyph annotation))
+(set-extent-end-glyph annotation (annotation-glyph annotation))))
+(define-obsolete-function-alias 'annotation-reveal 'reveal-annotation)
+;;;###autoload
+(defun annotations-in-region (start end buffer)
+"Return all annotations in BUFFER between START and END inclusively."
+(save-excursion
+(set-buffer buffer)
+(if (< start (point-min))
+(error "<start> not in range of buffer"))
+(if (> end (point-max))
+(error "<end> not in range of buffer"))
+(let (note-list)
+(map-extents
+(function (lambda (extent dummy)
+		   (progn
+		     (if (annotationp extent)
+			 (setq note-list (cons extent note-list)))
+		     nil)))
+buffer start end nil t)
+note-list)))
+;;;###autoload
+(defun annotations-at (&optional pos buffer)
+"Return a list of all annotations at POS in BUFFER.
+If BUFFER is nil, the current buffer is used.  If POS is nil, point is used."
+(if (not buffer)
+(setq buffer (current-buffer)))
+(if (not pos)
+(save-excursion
+	(set-buffer buffer)
+	(setq pos (point))))
+(annotations-in-region pos pos buffer)
+)
+;;;###autoload
+(defun annotation-list (&optional buffer)
+"Return a list of all annotations in BUFFER.
+If BUFFER is nil, the current buffer is used."
+(if (not buffer)
+(setq buffer (current-buffer)))
+(save-excursion
+(set-buffer buffer)
+(annotations-in-region (point-min) (point-max) buffer)))
+;;;###autoload
+(defun all-annotations ()
+"Return a list of all annotations in existence."
+(let ((b (buffer-list))
+	result)
+(while b
+(setq result (nconc result (annotation-list (car b))))
+(setq b (cdr b)))
+result))
+;;; #### really this menus junk should append to the prevailing menu
+;;;      in the same way `popup-mode-menu' does.  --jwz
+;; annotations menu stuff
+(defun annotation-popup-menu (event)
+"Pop up a menu of annotations commands.
+Point is temporarily moved to the click position."
+(interactive "e")
+(let ((extent (event-glyph-extent event)))
+(save-excursion
+(goto-char (extent-end-position extent))
+(if (annotation-menu extent)
+	  (popup-menu (annotation-menu extent))
+	(popup-mode-menu)))))
+(defun set-annotation-menu (annotation menu)
+"Set the menu field of ANNOTATION to MENU.  The function
+`annotation-menu' returns the current menu."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aset (extent-property annotation 'annotation) 2 menu)))
+(defun annotation-menu (annotation)
+"Return the menu associated with annotation ANNOTATION.  The menu
+is set using `set-annotation-menu'."
+(if (not (annotationp annotation))
+(error "%s is not an annotation" annotation)
+(aref (extent-property annotation 'annotation) 2)))
+(provide 'annotations)

Mercurial > hg > xemacs-beta

comparison lisp/utils/annotations.el @ 0:376386a54a3c r19-14