Mercurial > hg > xemacs-beta

comparison lisp/modes/outl-mouse.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; outl-mouse.el --- outline mode mouse commands for Emacs
2
3 ;; Copyright 1994 (C) Andy Piper <ajp@eng.cam.ac.uk>
4 ;; Keywords: outlines, mouse
5
6 ;; This file is part of XEmacs.
7
8 ;; XEmacs is free software; you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
11 ;; any later version.
12
13 ;; XEmacs is distributed in the hope that it will be useful, but
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;; General Public License for more details.
17
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with XEmacs; see the file COPYING. If not, write to the Free
20 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
21 ;;
22 ;; outl-mouse.el v1.3.8:
23 ;;
24 ;; Defines button one to hide blocks when clicked on outline-up-arrow
25 ;; and expand blocks when clicked on outline-down-arrow. Features are
26 ;; activated when outline-minor-mode or outline-mode are turned
27 ;; on. There is also a menu for each glyph on button 3.
28 ;;
29 ;; To use put:
30 ;; (require 'outl-mouse)
31 ;; in your .emacs file.
32 ;;
33 ;; If you use func-menu all the time and want outl-mouse on all the
34 ;; time as well then put:
35 ;; (setq outline-sync-with-func-menu t)
36 ;; outlining will then be turned on when func-menu is. Note that this
37 ;; requires a patch to func-menu 2.16 (in 19.10) to work:
38 ;;
39 ;RCS file: func-menu.el,v
40 ;retrieving revision 1.1
41 ;diff -r1.1 func-menu.el
42 ;180a181,183
43 ;> (defvar fume-found-function-hook nil
44 ;> "*Hook to call after every function match.")
45 ;>
46 ;1137,1138c1140,1142
47 ;< (if (listp funcname)
48 ;< (setq funclist (cons funcname funclist)))
49 ;---
50 ;> (cond ((listp funcname)
51 ;> (setq funclist (cons funcname funclist))
52 ;> (save-excursion (run-hooks 'fume-found-function-hook))))
53 ;;
54 ;; If you want mac-style outlining then set outline-mac-style to t.
55 ;; If you want the outline arrows on the left then set
56 ;; outline-glyphs-on-left to t. If you have xpm then arrows are much
57 ;; better defined.
58 ;;
59 ;; This package uses func-menu to define outline regexps if they are
60 ;; not already defined. You should no longer need to use out-xtra.
61 ;;
62 ;; You can define the package to do something other than outlining by
63 ;; setting outline-fold-in-function and outline-fold-out-function.
64 ;;
65 ;; You can define the color of outline arrows, but only in your .emacs.
66 ;;
67 ;; Only works in XEmacs 19.10 and onwards.
68 ;;
69 ;; User definable variables.
70 ;;
71 (defvar outline-mac-style nil
72 "*If t then outline glyphs will be right and down arrows.")
73
74 (defvar outline-glyphs-on-left nil
75 "*The position of outline glyphs on a line.")
76
77 (defvar outline-glyph-colour "Gray75"
78 "*The colour of outlining arrows.")
79
80 (defvar outline-glyph-shade-colour "Gray40"
81 "*The shadow colour of outlining arrows.")
82
83 (defvar outline-glyph-lit-colour "Gray90"
84 "*The lit colour of outlining arrows.")
85
86 (defvar outline-fold-in-function 'outline-fold-in
87 "Function to call for folding in.
88 The function should take an annotation argument.")
89 (make-variable-buffer-local 'outline-fold-in-function)
90
91 (defvar outline-fold-out-function 'outline-fold-out
92 "Function to call for folding out.
93 The function should take an annotation argument.")
94 (make-variable-buffer-local 'outline-fold-out-function)
95
96 (defvar outline-sync-with-func-menu nil
97 "*If t then outline glyphs are permanently added by func-menu scans.
98 If outline-minor-mode is turned off then turing it back on will have
99 no effect. Instead the buffer should be rescanned from the function
100 menu.")
101
102 (defvar outline-move-point-after-click t
103 "*If t then point is moved to the current heading when clicked.")
104
105 (defvar outline-scanning-message "Adding glyphs... (%3d%%)"
106 "*Progress message during the scanning of the buffer.
107 Set this to nil to inhibit progress messages.")
108
109 ;;
110 ;; No user definable variables beyond this point.
111 ;;
112 (defconst outline-up-arrow
113 (make-pixmap ; an up-arrow
114 (if (featurep 'xpm)
115 (concat "/* XPM */
116 static char * arrow[] = {
117 \"10 10 5 1\",
118 \" c none\",
119 \". c " outline-glyph-lit-colour "\",
120 \"X c " outline-glyph-shade-colour "\",
121 \"o c " outline-glyph-colour "\",
122 \"O c " outline-glyph-shade-colour "\",
123 \" .X \",
124 \" .X \",
125 \" ..XX \",
126 \" ..XX \",
127 \" ..ooXX \",
128 \" ..ooXX \",
129 \" ..ooooXX \",
130 \" ..ooooXX \",
131 \"..OOOOOOXX\",
132 \"OOOOOOOOOO\"};")
133 (list 10 10 (concat "\000\000\000\000\060\000\060\000\150\000"
134 "\150\000\324\000\324\000\376\001\376\001"))))
135 "Bitmap object for outline up glyph.")
136
137 (defconst outline-up-arrow-mask
138 (make-pixmap ; an up-arrow
139 (if (featurep 'xpm)
140 (concat "/* XPM */
141 static char * arrow[] = {
142 \"10 10 5 1\",
143 \" c none\",
144 \". c " outline-glyph-shade-colour "\",
145 \"X c " outline-glyph-lit-colour "\",
146 \"o c " outline-glyph-colour "\",
147 \"O c " outline-glyph-lit-colour "\",
148 \" .X \",
149 \" .X \",
150 \" ..XX \",
151 \" ..XX \",
152 \" ..ooXX \",
153 \" ..ooXX \",
154 \" ..ooooXX \",
155 \" ..ooooXX \",
156 \"..OOOOOOXX\",
157 \"OOOOOOOOOO\"};")
158 (list 10 10 (concat "\000\000\000\000\060\000\060\000\130\000"
159 "\130\000\254\000\274\000\006\001\376\001"))))
160 "Bitmap object for outline depressed up glyph.")
161
162 (defconst outline-down-arrow
163 (make-pixmap ; a down-arrow
164 (if (featurep 'xpm)
165 (concat "/* XPM */
166 static char * down[] = {
167 \"10 10 5 1\",
168 \" c " outline-glyph-lit-colour "\",
169 \". c " outline-glyph-lit-colour "\",
170 \"X c " outline-glyph-shade-colour "\",
171 \"o c none\",
172 \"O c " outline-glyph-colour "\",
173 \" \",
174 \".. XX\",
175 \"o..OOOOXXo\",
176 \"o..OOOOXXo\",
177 \"oo..OOXXoo\",
178 \"oo..OOXXoo\",
179 \"ooo..XXooo\",
180 \"ooo..XXooo\",
181 \"oooo.Xoooo\",
182 \"oooo.Xoooo\"};")
183 (list 10 10 (concat "\000\000\000\000\376\001\202\001\364\000"
184 "\324\000\150\000\150\000\060\000\060\000"))))
185 "Bitmap object for outline down glyph.")
186
187 (defconst outline-down-arrow-mask
188 (make-pixmap ; a down-arrow
189 (if (featurep 'xpm)
190 (concat "/* XPM */
191 static char * down[] = {
192 \"10 10 5 1\",
193 \" c " outline-glyph-shade-colour "\",
194 \". c " outline-glyph-shade-colour "\",
195 \"X c " outline-glyph-lit-colour "\",
196 \"o c none\",
197 \"O c " outline-glyph-colour "\",
198 \" \",
199 \".. XX\",
200 \"o..OOOOXXo\",
201 \"o..OOOOXXo\",
202 \"oo..OOXXoo\",
203 \"oo..OOXXoo\",
204 \"ooo..XXooo\",
205 \"ooo..XXooo\",
206 \"oooo.Xoooo\",
207 \"oooo.Xoooo\"};")
208 (list 10 10 (concat "\000\000\000\000\376\001\376\001\254\000"
209 "\254\000\130\000\130\000\060\000\060\000"))))
210 "Bitmap object for outline depressed down glyph.")
211
212 (defconst outline-right-arrow
213 (make-pixmap ; a right-arrow
214 (if (featurep 'xpm)
215 (concat "/* XPM */
216 static char * right[] = {
217 \"10 10 5 1\",
218 \" c " outline-glyph-lit-colour "\",
219 \". c " outline-glyph-lit-colour "\",
220 \"X c none\",
221 \"o c " outline-glyph-colour "\",
222 \"O c " outline-glyph-shade-colour "\",
223 \" .XXXXXXXX\",
224 \" ...XXXXXX\",
225 \" ....XXXX\",
226 \" oo....XX\",
227 \" oooo....\",
228 \" ooooOOOO\",
229 \" ooOOOOXX\",
230 \" OOOOXXXX\",
231 \" OOOXXXXXX\",
232 \" OXXXXXXXX\"};")
233 (list 10 10 (concat "\000\000\006\000\032\000\142\000\232\001"
234 "\352\001\172\000\036\000\006\000\000\000"))))
235 "Bitmap object for outline right glyph.")
236
237 (defconst outline-right-arrow-mask
238 (make-pixmap ; a right-arrow
239 (if (featurep 'xpm)
240 (concat "/* XPM */
241 static char * right[] = {
242 \"10 10 5 1\",
243 \" c " outline-glyph-shade-colour "\",
244 \". c " outline-glyph-shade-colour "\",
245 \"X c none\",
246 \"o c " outline-glyph-colour "\",
247 \"O c " outline-glyph-lit-colour "\",
248 \" .XXXXXXXX\",
249 \" ...XXXXXX\",
250 \" ....XXXX\",
251 \" oo....XX\",
252 \" oooo....\",
253 \" ooooOOOO\",
254 \" ooOOOOXX\",
255 \" OOOOXXXX\",
256 \" OOOXXXXXX\",
257 \" OXXXXXXXX\"};")
258 (list 10 10 (concat "\000\000\006\000\036\000\176\000\346\001"
259 "\236\001\146\000\036\000\006\000\000\000"))))
260 "Bitmap object for outline depressed right glyph.")
261
262 (defvar outline-glyph-menu
263 '("Outline Commands"
264 ["Hide all" hide-body t]
265 ["Hide all subtrees" hide-subtrees-same-level t]
266 "---"
267 ["Hide subtree" hide-subtree t]
268 ["Hide body" hide-body t]
269 ["Show subtree" show-subtree t]
270 ["Show body" show-entry t]
271 "---"
272 ["Update buffer" outline-add-glyphs t]
273 ["Rescan buffer" outline-rescan-buffer t])
274 "Menu of commands for outline glyphs.")
275
276 (set-pixmap-contributes-to-line-height outline-down-arrow nil)
277 (set-pixmap-contributes-to-line-height outline-up-arrow nil)
278 (set-pixmap-contributes-to-line-height outline-down-arrow-mask nil)
279 (set-pixmap-contributes-to-line-height outline-up-arrow-mask nil)
280 (set-pixmap-contributes-to-line-height outline-right-arrow nil)
281 (set-pixmap-contributes-to-line-height outline-right-arrow-mask nil)
282
283 (require 'annotations)
284 (require 'advice) ; help me doctor !
285 (require 'outline)
286 (require 'func-menu) ; for those most excellent regexps.
287
288 (add-hook 'outline-mode-hook 'outline-mouse-hooks)
289 (add-hook 'outline-minor-mode-hook 'outline-mouse-hooks)
290 ;; I thought this was done already ...
291 (make-variable-buffer-local 'outline-regexp)
292 (make-variable-buffer-local 'outline-level)
293
294 (cond (outline-sync-with-func-menu
295 (add-hook 'fume-found-function-hook 'outline-heading-add-glyph-1)
296 (setq-default fume-rescan-buffer-hook '(lambda ()
297 (outline-minor-mode 1)))))
298
299 (defadvice fume-set-defaults (after fume-set-defaults-ad activate)
300 "Advise fume-set-defaults to setup outline regexps."
301 (if (and (not (assq 'outline-regexp (buffer-local-variables)))
302 fume-function-name-regexp)
303 (progn
304 (setq outline-regexp (if (listp fume-function-name-regexp)
305 (car fume-function-name-regexp)
306 fume-function-name-regexp))
307 (setq outline-level '(lambda () 1)))))
308
309 (defadvice outline-minor-mode (after outline-mode-mouse activate)
310 "Advise outline-minor-mode to delete glyphs when switched off."
311 (if (not outline-minor-mode)
312 (progn
313 (outline-delete-glyphs)
314 (show-all))))
315
316 ;; advise all outline commands so that glyphs are synced after use
317 (defadvice show-all (after show-all-ad activate)
318 "Advise show-all to sync headings."
319 (outline-sync-visible-sub-headings-in-region (point-min) (point-max)))
320
321 (defadvice hide-subtree (after hide-subtree-ad activate)
322 "Advise hide-subtree to sync headings."
323 (outline-sync-visible-sub-headings))
324
325 (defadvice hide-entry (after hide-entry-ad activate)
326 "Advise hide-entry to sync headings."
327 (outline-sync-visible-sub-headings))
328
329 (defadvice hide-body (after hide-body-ad activate)
330 "Advise hide-body to sync headings."
331 (outline-sync-visible-sub-headings-in-region (point-min) (point-max)))
332
333 (defadvice show-subtree (after show-subtree-ad activate)
334 "Advise show-subtree to sync headings."
335 (outline-sync-visible-sub-headings))
336
337 (defadvice show-entry (after show-entry-ad activate)
338 "Advise shown-entry to sync headings."
339 (outline-sync-visible-sub-headings))
340
341 ;;;###autoload
342 (defun outl-mouse-mode ()
343 "Calls outline-mode, with outl-mouse extensions"
344 (interactive)
345 (outline-mode))
346
347 ;;;###autoload
348 (defun outl-mouse-minor-mode (&optional arg)
349 "Toggles outline-minor-mode, with outl-mouse extensions"
350 (interactive "P")
351 (outline-minor-mode arg))
352
353 (defun hide-subtrees-same-level ()
354 "Hide all subtrees below the current level."
355 (interactive)
356 (save-excursion
357 (while (progn
358 (hide-subtree)
359 (condition-case nil
360 (progn
361 (outline-forward-same-level 1)
362 t)
363 (error nil))))))
364
365 (defun outline-mouse-hooks ()
366 "Hook for installing outlining with the mouse."
367 ;; use function menu regexps if not set
368 (fume-set-defaults)
369 ;; only add glyphs when we're not synced.
370 (if (not outline-sync-with-func-menu) (outline-add-glyphs))
371 ;; add C-a to local keymap
372 (let ((outline (cond ((keymapp (lookup-key (current-local-map)
373 outline-minor-mode-prefix))
374 (lookup-key (current-local-map)
375 outline-minor-mode-prefix))
376 (t
377 (define-key (current-local-map)
378 outline-minor-mode-prefix (make-sparse-keymap))
379 (lookup-key (current-local-map)
380 outline-minor-mode-prefix)))))
381 (define-key outline "\C-a" 'outline-heading-add-glyph)
382 (define-key outline-mode-map "\C-c\C-a" 'outline-heading-add-glyph)))
383
384 (defun outline-add-glyphs ()
385 "Add annotations and glyphs to all heading lines that don't have them."
386 (interactive)
387 (save-excursion
388 (and outline-scanning-message (message outline-scanning-message 0))
389 (goto-char (point-min))
390 (if (not (outline-on-heading-p)) (outline-next-visible-heading-safe))
391 (while
392 (progn
393 (outline-heading-add-glyph-1)
394 (and outline-scanning-message
395 (message outline-scanning-message (fume-relative-position)))
396 (outline-next-visible-heading-safe)))
397 (and outline-scanning-message
398 (message "%s done" (format outline-scanning-message 100)))))
399
400 (defun outline-delete-glyphs ()
401 "Remove annotations and glyphs from heading lines."
402 (save-excursion
403 (mapcar 'outline-heading-delete-glyph (annotation-list))))
404
405 (defun outline-rescan-buffer ()
406 "Remove and insert all annotations."
407 (interactive)
408 (outline-delete-glyphs)
409 (outline-add-glyphs)
410 (save-excursion
411 (outline-sync-visible-sub-headings-in-region (point-min) (point-max))))
412
413 (defun outline-heading-delete-glyph (ext)
414 "Delete annotation and glyph from a heading with annotation EXT."
415 (if (and
416 (progn
417 (goto-char (extent-start-position ext))
418 (beginning-of-line)
419 (outline-on-heading-p))
420 (extent-property ext 'outline))
421 (delete-annotation ext))
422 nil)
423
424 (defun outline-heading-add-glyph ()
425 "Interactive version of outline-heading-add-glyph-1."
426 (interactive)
427 (save-excursion
428 (outline-heading-add-glyph-1)))
429
430 (defun outline-heading-add-glyph-1 ()
431 "Add glyph to the end of heading line which point is on.
432 Returns nil if point is not on a heading or glyph already exists."
433 (if (or (not (outline-on-heading-p))
434 (outline-heading-has-glyph-p)
435 (save-excursion (forward-line) (outline-on-heading-p)))
436 nil
437 (outline-back-to-heading)
438 (let ((anot2
439 (make-annotation (if outline-mac-style
440 outline-right-arrow
441 outline-down-arrow)
442 (save-excursion (if outline-glyphs-on-left nil
443 (outline-end-of-heading))
444 (point))
445 'text nil t
446 (if outline-mac-style
447 outline-right-arrow-mask
448 outline-down-arrow-mask)))
449 (anot1
450 (make-annotation (if outline-mac-style
451 outline-down-arrow
452 outline-up-arrow)
453 (save-excursion (if outline-glyphs-on-left nil
454 (outline-end-of-heading))
455 (point))
456 'text nil t
457 (if outline-mac-style
458 outline-down-arrow-mask
459 outline-up-arrow-mask))))
460 ;; we cunningly make the annotation data point to its twin.
461 (set-annotation-data anot1 anot2)
462 (set-extent-property anot1 'outline 'up)
463 (set-annotation-action anot1 'outline-up-click)
464 (set-annotation-menu anot1 outline-glyph-menu)
465 (set-extent-priority anot1 1)
466 (set-annotation-data anot2 anot1)
467 (set-extent-property anot2 'outline 'down)
468 (set-annotation-menu anot2 outline-glyph-menu)
469 (set-annotation-action anot2 'outline-down-click)
470 (annotation-hide anot2))
471 t))
472
473 (defun outline-heading-has-glyph-p ()
474 "Return t if heading has an outline glyph."
475 (catch 'found
476 (mapcar
477 '(lambda(a)
478 (if (extent-property a 'outline)
479 (throw 'found t)))
480 (annotations-in-region (save-excursion (outline-back-to-heading) (point))
481 (save-excursion (outline-end-of-heading)
482 (+ 1 (point)))
483 (current-buffer)))
484 nil))
485
486 (defun outline-sync-visible-sub-headings-in-region (pmin pmax)
487 "Make sure all anotations on headings in region PMIN PMAX are
488 displayed correctly."
489 (mapcar '(lambda (x)
490 (goto-char (extent-start-position x))
491 (beginning-of-line)
492 (cond ((and (eq (extent-property x 'outline) 'down)
493 ;; skip things we can't see
494 (not (eq (preceding-char) ?\^M)))
495 (if (outline-more-to-hide)
496 ;; reveal my twin
497 (annotation-reveal (annotation-data x))
498 (annotation-hide (annotation-data x)))
499 (if (not (outline-hidden-p))
500 ;; hide my self
501 (annotation-hide x)
502 (annotation-reveal x)))))
503 (annotations-in-region pmin pmax (current-buffer))))
504
505 (defun outline-sync-visible-sub-headings ()
506 "Make sure all anotations on sub-headings below the one point is on are
507 displayed correctly."
508 (outline-sync-visible-sub-headings-in-region
509 (point)
510 (progn (outline-end-of-subtree) (point))))
511
512 (defun outline-fold-out (annotation)
513 "Fold out the current heading."
514 (beginning-of-line)
515 ; (if (not (equal (condition-case nil
516 ; (save-excursion (outline-next-visible-heading 1)
517 ; (point))
518 ; (error nil))
519 ; (save-excursion (outline-next-heading)
520 ; (if (eobp) nil (point)))))
521 (if (save-excursion (outline-next-heading)
522 (eq (preceding-char) ?\^M))
523 (progn
524 (save-excursion (show-children))
525 (outline-sync-visible-sub-headings))
526 ;; mess with single entry
527 (if (outline-hidden-p)
528 (progn
529 (save-excursion (show-entry))
530 ;; reveal my twin and hide me
531 (annotation-hide annotation)
532 (annotation-reveal (annotation-data annotation))))))
533
534 (defun outline-fold-in (annotation)
535 "Fold in the current heading."
536 (beginning-of-line)
537 ;; mess with single entries
538 (if (not (outline-hidden-p))
539 (progn
540 (save-excursion (hide-entry))
541 (if (not (outline-more-to-hide))
542 (annotation-hide annotation))
543 (annotation-reveal (annotation-data annotation)))
544 ;; otherwise look for more leaves
545 (save-excursion
546 (if (outline-more-to-hide t)
547 (hide-subtree)
548 (hide-leaves)))
549 ;; sync everything
550 (outline-sync-visible-sub-headings)))
551
552 (defun outline-more-to-hide (&optional arg)
553 "Return t if there are more visible sub-headings or text.
554 With ARG return t only if visible sub-headings have no visible text."
555 (if (not (outline-hidden-p))
556 (if arg nil t)
557 (save-excursion
558 (and (< (funcall outline-level) (condition-case nil
559 (progn
560 (outline-next-visible-heading 1)
561 (funcall outline-level))
562 (error 0)))
563 (if (and (not (outline-hidden-p)) arg)
564 nil t)))))
565
566 (defun outline-hidden-p ()
567 "Return t if point is on the header of a hidden subtree."
568 (save-excursion
569 (let ((end-of-entry (save-excursion (outline-next-heading))))
570 ;; Make sure that the end of the entry really exists.
571 (if (not end-of-entry)
572 (setq end-of-entry (point-max)))
573 (outline-back-to-heading)
574 ;; If there are ANY ^M's, the entry is hidden.
575 (search-forward "\^M" end-of-entry t))))
576
577 (defun outline-next-visible-heading-safe ()
578 "Safely go to the next visible heading.
579 nil is returned if there is none."
580 (condition-case nil
581 (progn
582 (outline-next-visible-heading 1)
583 t)
584 (error nil)))
585
586 (defun outline-up-click (data ev)
587 "Annotation action for clicking on an up arrow.
588 DATA is the annotation data. EV is the mouse click event."
589 (save-excursion
590 (goto-char (extent-end-position (event-glyph-extent ev)))
591 (funcall outline-fold-in-function (event-glyph-extent ev)))
592 (if outline-move-point-after-click
593 (progn
594 (goto-char (extent-end-position (event-glyph-extent ev)))
595 (beginning-of-line))))
596 ; This line demonstrates a bug in redisplay
597 (defun outline-down-click (data ev)
598 "Annotation action for clicking on a down arrow.
599 DATA is the annotation data. EV is the mouse click event."
600 (save-excursion
601 (goto-char (extent-end-position (event-glyph-extent ev)))
602 (funcall outline-fold-out-function (event-glyph-extent ev)))
603 (if outline-move-point-after-click
604 (progn
605 (goto-char (extent-end-position (event-glyph-extent ev)))
606 (beginning-of-line))))
607
608
609 (provide 'outl-mouse)
610 (provide 'outln-18) ; fool auctex - outline is ok now.
611
612 ;; Local Variables:
613 ;; outline-regexp: ";;; \\|(def.."
614 ;; End:
615
616
617