cgit.sxemacs.org Git - packages/blob - xemacs-packages/xemacs-base/annotations.el

   1 ;;; annotations.el --- interface to marginal annotations
   2
   3 ;; Copyright (C) 1992-1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Created: 10-Oct-93
   8 ;; Keywords: extensions, hypermedia, outlines
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;; Enhanced by Andy Piper <ajp@eng.cam.ac.uk>: 6-may-94
  32
  33 ;; Last modified:  12-May-95 by Chuck Thompson.
  34
  35 ;; The annotations are implemented on top of extents.  The extent property
  36 ;; 'annotation of an extent being used as an annotation is vector of size 6:
  37 ;;      [<data> <action> <menu> <glyph> <down-glyph> <rightp>]
  38 ;;
  39
  40 ;;; Code:
  41
  42 ;;;###autoload
  43 (defvar make-annotation-hook nil
  44   "*Function or functions to run immediately after creating an annotation.")
  45
  46 ;;;###autoload
  47 (defvar before-delete-annotation-hook nil
  48   "*Function or functions to run immediately before deleting an annotation.")
  49
  50 ;;;###autoload
  51 (defvar after-delete-annotation-hook nil
  52   "*Function or functions to run immediately after deleting an annotation.")
  53
  54 (defvar annotation-local-map-default
  55   (let ((map (make-sparse-keymap)))
  56     (set-keymap-name map 'annotation-local-map)
  57     (define-key map 'button1 'annotation-activate-function-default)
  58     (define-key map 'button3 'annotation-popup-menu)
  59     map)
  60   "Keymap used to activate annotations with only annotation data passed.")
  61
  62 (defvar annotation-local-map-with-event
  63   (let ((map (make-sparse-keymap)))
  64     (set-keymap-name map 'annotation-local-map)
  65     (define-key map 'button1 'annotation-activate-function-with-event)
  66     (define-key map 'button3 'annotation-popup-menu)
  67     map)
  68   "Keymap used to activate annotations with annotation data and event passed.")
  69
  70 ;;
  71 ;; When the mouse is pressed and released over an annotation glyph
  72 ;; this will run the annotation action passing a single arg, the value
  73 ;; of the annotation data field.
  74 ;;
  75 (defun annotation-activate-function-default (event)
  76   (interactive "e")
  77   (let ((extent (event-glyph-extent event))
  78         (mouse-down t)
  79         (up-glyph nil))
  80     ;; make the glyph look pressed
  81     (cond ((annotation-down-glyph extent)
  82            (setq up-glyph (annotation-glyph extent))
  83            (set-annotation-glyph extent (annotation-down-glyph extent))))
  84     (while mouse-down
  85       (setq event (next-event event))
  86       (if (button-release-event-p event)
  87           (setq mouse-down nil)))
  88     ;; make the glyph look released
  89     (cond ((annotation-down-glyph extent)
  90            (set-annotation-glyph extent up-glyph)))
  91     (if (eq extent (event-glyph-extent event))
  92         (if (annotation-action extent)
  93             (funcall (annotation-action extent) (annotation-data extent))))))
  94
  95 ;;
  96 ;; When the mouse is pressed and released over an annotation glyph
  97 ;; this will run the annotation action passing two args, the value
  98 ;; of the annotation data field and the event which triggered the
  99 ;; annotation.
 100 ;;
 101 (defun annotation-activate-function-with-event (event)
 102   (interactive "e")
 103   (let ((extent (event-glyph-extent event))
 104         (mouse-down t)
 105         (up-glyph nil))
 106     ;; make the glyph look pressed
 107     (cond ((annotation-down-glyph extent)
 108            (setq up-glyph (annotation-glyph extent))
 109            (set-annotation-glyph extent (annotation-down-glyph extent))))
 110     (while mouse-down
 111       (setq event (next-event event))
 112       (if (button-release-event-p event)
 113           (setq mouse-down nil)))
 114     ;; make the glyph look released
 115     (cond ((annotation-down-glyph extent)
 116            (set-annotation-glyph extent up-glyph)))
 117     (if (eq extent (event-glyph-extent event))
 118         (if (annotation-action extent)
 119             (funcall (annotation-action extent) (annotation-data extent)
 120                      event)))))
 121
 122 ;; #### Glyphs should be glyphs should be glyphs
 123 ;;;###autoload
 124 (defun make-annotation (glyph &optional pos layout buffer with-event d-glyph rightp)
 125   "Create a marginal annotation, displayed using GLYPH, at position POS.
 126 GLYPH may be either a glyph object or a string.  Use layout policy
 127 LAYOUT and place the annotation in buffer BUFFER.  If POS is nil, point is
 128 used.  If LAYOUT is nil, `whitespace' is used.  If BUFFER is nil, the
 129 current buffer is used.  If WITH-EVENT is non-nil, then when an annotation
 130 is activated, the triggering event is passed as the second arg to the
 131 annotation function.  If D-GLYPH is non-nil then it is used as the glyph
 132 that will be displayed when button1 is down.  If RIGHTP is non-nil then
 133 the glyph will be displayed on the right side of the buffer instead of the
 134 left."
 135   (let ((new-annotation))
 136     ;; get the buffer to add the annotation at
 137     (if (not buffer)
 138         (setq buffer (current-buffer))
 139       (setq buffer (get-buffer buffer)))
 140     ;; get the position to put it at
 141     (if (not pos)
 142         (save-excursion
 143           (set-buffer buffer)
 144           (setq pos (point))))
 145     ;; make sure it gets some layout policy
 146     (if (not layout)
 147         (setq layout 'whitespace))
 148
 149     ;; make sure the glyph arguments are actually glyphs
 150     (if (and glyph (not (glyphp glyph)))
 151         (setq glyph (make-glyph glyph)))
 152     (if (and d-glyph (not (glyphp d-glyph)))
 153         (setq d-glyph (make-glyph d-glyph)))
 154
 155     ;; create the actual annotation
 156     (setq new-annotation (make-extent pos pos buffer))
 157     (detach-extent new-annotation)
 158     (set-extent-endpoints new-annotation pos pos)
 159     (if rightp
 160         (set-extent-end-glyph new-annotation glyph layout)
 161       (set-extent-begin-glyph new-annotation glyph layout))
 162     (set-extent-property new-annotation 'annotation
 163                          (vector nil nil nil glyph d-glyph rightp))
 164     (set-extent-property new-annotation 'end-closed t)
 165     (set-extent-property new-annotation 'start-open t)
 166     (set-extent-property new-annotation 'duplicable t)
 167     (if with-event
 168         (set-extent-property new-annotation 'keymap
 169                              annotation-local-map-with-event)
 170       (set-extent-property new-annotation 'keymap
 171                            annotation-local-map-default))
 172     (run-hook-with-args 'make-annotation-hook new-annotation)
 173     new-annotation))
 174
 175 (fset 'make-graphic-annotation 'make-annotation)
 176 (make-obsolete 'make-graphic-annotation 'make-annotation)
 177
 178 ;;;###autoload
 179 (defun delete-annotation (annotation)
 180   "Remove ANNOTATION from its buffer.  This does not modify the buffer text."
 181   (if (not (annotationp annotation))
 182       (error "%s is not an annotation" annotation)
 183     (progn
 184       (run-hook-with-args 'before-delete-annotation-hook annotation)
 185       (delete-extent annotation)
 186       (run-hooks 'after-delete-annotation-hook))))
 187
 188 ;;;###autoload
 189 (defun annotationp (annotation)
 190   "T if OBJECT is an annotation."
 191   (and (extent-live-p annotation)
 192        (not (null (extent-property annotation 'annotation)))))
 193
 194 (defun annotation-visible (annotation)
 195   "T if there is enough available space to display ANNOTATION."
 196   (if (not (annotationp annotation))
 197       (error "%s is not an annotation" annotation)
 198     (not (extent-property annotation 'glyph-invisible))))
 199
 200 ;;;###autoload
 201 (defun annotation-at (&optional pos buffer)
 202   "Return the first annotation at POS in BUFFER.
 203 BUFFER defaults to the current buffer.  POS defaults to point in BUFFER."
 204   (car (annotations-at pos buffer)))
 205 (make-obsolete 'annotation-at 'annotations-at)
 206
 207 (defun annotation-layout (annotation)
 208   "Return the layout policy of annotation ANNOTATION.  The layout policy
 209 is set using `set-annotation-layout'."
 210   (if (not (annotationp annotation))
 211       (error "%s is not an annotation" annotation)
 212     (if (eq 'right (annotation-side annotation))
 213         (extent-end-glyph-layout annotation)
 214       (extent-begin-glyph-layout annotation))))
 215
 216
 217 (defun annotation-side (annotation)
 218   "Return the side of the buffer the annotation is displayed on.
 219 Return value is either 'left or 'right."
 220   (if (aref (extent-property annotation 'annotation) 5)
 221       'right
 222     'left))
 223
 224 (defun set-annotation-layout (annotation layout)
 225   "Set the layout policy of ANNOTATION to LAYOUT.  The function
 226 `annotation-layout' returns the current layout policy."
 227   (if (not (annotationp annotation))
 228       (error "%s is not an annotation" annotation)
 229     (if (eq 'right (annotation-side annotation))
 230         (set-extent-end-glyph-layout annotation layout)
 231       (set-extent-begin-glyph-layout annotation layout))))
 232
 233 ;; Now that annotations use glyphs this function has little value and
 234 ;; will actually not work as is.
 235 ;(defun annotation-type (annotation)
 236 ;  "Return the display type of the annotation ANNOTATION.  The type will
 237 ;be one of the following symbols:
 238 ;
 239 ;       pixmap
 240 ;       bitmap
 241 ;       string
 242 ;       nil     (the object is not an annotation)"
 243 ;  (if (not (annotationp annotation))
 244 ;      nil
 245 ;    (let ((glyph (annotation-glyph annotation)))
 246 ;      (if (stringp glyph)
 247 ;         'stringp
 248 ;       (if (not (pixmapp glyph))
 249 ;           (error "%s is a corrupt annotation" annotation)
 250 ;         (if (> (pixmap-depth glyph) 0)
 251 ;             'pixmap
 252 ;           'bitmap))))))
 253 (make-obsolete 'annotation-type "This function no longer has any meaning.")
 254
 255 (defun annotation-width (annotation)
 256   "Return the width of the annotation ANNOTATION in pixels."
 257   (if (not (annotationp annotation))
 258       (error "%s is not an annotation" annotation)
 259     (glyph-width (annotation-glyph annotation))))
 260
 261 (defun annotation-glyph (annotation)
 262   "If ANNOTATION is of type `string' return the string.  Otherwise, return
 263 the glyph object used to display ANNOTATION.  The glyph is set using
 264 `set-annotation-glyph'."
 265   (if (not (annotationp annotation))
 266       (error "%s is not an annotation" annotation)
 267     (aref (extent-property annotation 'annotation) 3)))
 268
 269 (defun set-annotation-glyph (annotation glyph &optional layout side)
 270   "Set the representation of ANNOTATION to GLYPH.
 271 GLYPH should be a glyph object.  If LAYOUT is non-nil, set the layout
 272 policy of the annotation to LAYOUT.  If SIDE is equal to 'left or 'right
 273 change the side of the annotation to that value.
 274 The function `annotation-glyph' returns the current glyph."
 275   (if (not (annotationp annotation))
 276       (error "%s is not an annotation" annotation)
 277     ;; else
 278     (or layout (setq layout (annotation-layout annotation)))
 279     (or side   (setq side   (annotation-side   annotation)))
 280     (cond ((eq side 'left)
 281            (set-extent-begin-glyph annotation glyph layout)
 282            (set-extent-end-glyph annotation nil)
 283            (aset (extent-property annotation 'annotation) 5 nil))
 284           ((eq side 'right)
 285            (set-extent-end-glyph annotation glyph layout)
 286            (set-extent-begin-glyph annotation nil)
 287            (aset (extent-property annotation 'annotation) 5 nil)))
 288     (aset (extent-property annotation 'annotation) 3 glyph)
 289     (annotation-glyph annotation)))
 290
 291 (defun annotation-down-glyph (annotation)
 292   "If ANNOTATION is of type `string' return the down string.  Otherwise,
 293 return the glyph object of the down-glyph representing ANNOTATION.
 294 The down-glyph is set using `set-annotation-down-glyph'."
 295   (if (not (annotationp annotation))
 296       (error "%s is not an annotation" annotation)
 297     (aref (extent-property annotation 'annotation) 4)))
 298
 299 (defun set-annotation-down-glyph (annotation glyph)
 300   "Set the depressed representation of ANNOTATION to GLYPH.
 301 GLYPH should be a glyph object.
 302 The function `annotation-down-glyph' returns the current down-glyph."
 303   (if (not (annotationp annotation))
 304       (error "%s is not an annotation" annotation)
 305     (aset (extent-property annotation 'annotation) 4 glyph)))
 306
 307 (define-obsolete-function-alias 'annotation-graphic 'annotation-glyph)
 308 (define-obsolete-function-alias 'set-annotation-graphic 'set-annotation-glyph)
 309
 310 (defun annotation-data (annotation)
 311   "Return the data associated with annotation ANNOTATION.  The data is
 312 set using `set-annotation-data'."
 313   (if (not (annotationp annotation))
 314       (error "%s is not an annotation" annotation)
 315     (aref (extent-property annotation 'annotation) 0)))
 316
 317 (defun set-annotation-data (annotation data)
 318   "Set the data field of ANNOTATION to DATA.
 319 The function `annotation-data' returns the current data."
 320   (if (not (annotationp annotation))
 321       (error "%s is not an annotation" annotation)
 322     (aset (extent-property annotation 'annotation) 0 data)))
 323
 324 (defun annotation-action (annotation)
 325   "Return the action associated with annotation ANNOTATION.  The action
 326 is set using `set-annotation-action'."
 327   (if (not (annotationp annotation))
 328       (error "%s is not an annotation" annotation)
 329     (aref (extent-property annotation 'annotation) 1)))
 330
 331 (defun set-annotation-action (annotation action)
 332   "Set the action field of ANNOTATION to ACTION.
 333 The function `annotation-action' returns the current action."
 334   (if (not (annotationp annotation))
 335       (error "%s is not an annotation" annotation)
 336     (aset (extent-property annotation 'annotation) 1 action)))
 337
 338 (defun annotation-face (annotation)
 339   "Return the face associated with annotation ANNOTATION.
 340 The face is set using `set-annotation-face'."
 341   (if (not (annotationp annotation))
 342       (error "%s is not an annotation" annotation)
 343     (extent-face annotation)))
 344
 345 (defun set-annotation-face (annotation face)
 346   "Set the face associated with annotation ANNOTATION to FACE.
 347 The function `annotation-face' returns the current face."
 348   (if (not (annotationp annotation))
 349       (error "%s is not an annotation" annotation)
 350     (set-extent-face annotation face)))
 351
 352 (defun hide-annotation (annotation)
 353   "Remove ANNOTATION's glyph so that it is invisible."
 354   (if (eq (annotation-side annotation) 'left)
 355       (set-extent-begin-glyph annotation nil)
 356     (set-extent-end-glyph annotation nil)))
 357 (define-obsolete-function-alias 'annotation-hide 'hide-annotation)
 358
 359 (defun reveal-annotation (annotation)
 360   "Add ANNOTATION's glyph so that it is visible."
 361   (if (eq (annotation-side annotation) 'left)
 362       (set-extent-begin-glyph annotation (annotation-glyph annotation))
 363     (set-extent-end-glyph annotation (annotation-glyph annotation))))
 364 (define-obsolete-function-alias 'annotation-reveal 'reveal-annotation)
 365
 366 ;;;###autoload
 367 (defun annotations-in-region (start end buffer)
 368   "Return all annotations in BUFFER between START and END inclusively."
 369   (save-excursion
 370     (set-buffer buffer)
 371
 372     (if (< start (point-min))
 373       (error "<start> not in range of buffer"))
 374     (if (> end (point-max))
 375       (error "<end> not in range of buffer"))
 376
 377     (let (note-list)
 378       (map-extents #'(lambda (extent dummy)
 379                        (progn
 380                          (setq note-list (cons extent note-list))
 381                          nil))
 382                    buffer start end nil 'end-closed 'annotation)
 383       note-list)))
 384
 385 ;;;###autoload
 386 (defun annotations-at (&optional pos buffer)
 387   "Return a list of all annotations at POS in BUFFER.
 388 If BUFFER is nil, the current buffer is used.  If POS is nil, point is used."
 389   (if (not buffer)
 390       (setq buffer (current-buffer)))
 391   (if (not pos)
 392       (save-excursion
 393         (set-buffer buffer)
 394         (setq pos (point))))
 395
 396   (annotations-in-region pos pos buffer)
 397 )
 398
 399 ;;;###autoload
 400 (defun annotation-list (&optional buffer)
 401   "Return a list of all annotations in BUFFER.
 402 If BUFFER is nil, the current buffer is used."
 403   (if (not buffer)
 404     (setq buffer (current-buffer)))
 405
 406   (save-excursion
 407     (set-buffer buffer)
 408     (annotations-in-region (point-min) (point-max) buffer)))
 409
 410 ;;;###autoload
 411 (defun all-annotations ()
 412   "Return a list of all annotations in existence."
 413   (let ((b (buffer-list))
 414         result)
 415     (while b
 416       (setq result (nconc result (annotation-list (car b))))
 417       (setq b (cdr b)))
 418     result))
 419
 420 ;;; #### really this menus junk should append to the prevailing menu
 421 ;;;      in the same way `popup-mode-menu' does.  --jwz
 422
 423 ;; annotations menu stuff
 424 (defun annotation-popup-menu (event)
 425   "Pop up a menu of annotations commands.
 426 Point is temporarily moved to the click position."
 427   (interactive "e")
 428   (let ((extent (event-glyph-extent event)))
 429     (save-excursion
 430       (goto-char (extent-end-position extent))
 431       (if (annotation-menu extent)
 432           (popup-menu (annotation-menu extent))
 433         (popup-mode-menu)))))
 434
 435 (defun set-annotation-menu (annotation menu)
 436   "Set the menu field of ANNOTATION to MENU.  The function
 437 `annotation-menu' returns the current menu."
 438   (if (not (annotationp annotation))
 439       (error "%s is not an annotation" annotation)
 440     (aset (extent-property annotation 'annotation) 2 menu)))
 441
 442 (defun annotation-menu (annotation)
 443   "Return the menu associated with annotation ANNOTATION.  The menu
 444 is set using `set-annotation-menu'."
 445   (if (not (annotationp annotation))
 446       (error "%s is not an annotation" annotation)
 447     (aref (extent-property annotation 'annotation) 2)))
 448 \f
 449 (provide 'annotations)
 450
 451 ;;; annotations.el ends here