cgit.sxemacs.org Git - packages/blob - xemacs-packages/edit-utils/outl-mouse.el

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