lisp/textmodes/outline.el

   1 ;;; outline.el --- outline mode commands for Emacs
   2
   3 ;; Copyright (C) 1986, 93, 94, 95, 97, 2000 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: outlines
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package is a major mode for editing outline-format documents.
  28 ;; An outline can be `abstracted' to show headers at any given level,
  29 ;; with all stuff below hidden.  See the Emacs manual for details.
  30
  31 ;;; Code:
  32
  33 (defgroup outlines nil
  34   "Support for hierarchical outlining"
  35   :prefix "outline-"
  36   :group 'editing)
  37
  38 (defcustom outline-regexp nil
  39   "*Regular expression to match the beginning of a heading.
  40 Any line whose beginning matches this regexp is considered to start a heading.
  41 The recommended way to set this is with a Local Variables: list
  42 in the file it applies to.  See also `outline-heading-end-regexp'."
  43   :type '(choice regexp (const nil))
  44   :group 'outlines)
  45
  46 ;; Can't initialize this in the defvar above -- some major modes have
  47 ;; already assigned a local value to it.
  48 (or (default-value 'outline-regexp)
  49     (setq-default outline-regexp "[*\^L]+"))
  50
  51 (defcustom outline-heading-end-regexp "\n"
  52   "*Regular expression to match the end of a heading line.
  53 You can assume that point is at the beginning of a heading when this
  54 regexp is searched for.  The heading ends at the end of the match.
  55 The recommended way to set this is with a `Local Variables:' list
  56 in the file it applies to."
  57   :type 'regexp
  58   :group 'outlines)
  59
  60 (defvar outline-mode-prefix-map nil)
  61
  62 (if outline-mode-prefix-map
  63     nil
  64   (setq outline-mode-prefix-map (make-sparse-keymap))
  65   (define-key outline-mode-prefix-map "@" 'outline-mark-subtree)
  66   (define-key outline-mode-prefix-map "\C-n" 'outline-next-visible-heading)
  67   (define-key outline-mode-prefix-map "\C-p" 'outline-previous-visible-heading)
  68   (define-key outline-mode-prefix-map "\C-i" 'show-children)
  69   (define-key outline-mode-prefix-map "\C-s" 'show-subtree)
  70   (define-key outline-mode-prefix-map "\C-d" 'hide-subtree)
  71   (define-key outline-mode-prefix-map "\C-u" 'outline-up-heading)
  72   (define-key outline-mode-prefix-map "\C-f" 'outline-forward-same-level)
  73   (define-key outline-mode-prefix-map "\C-b" 'outline-backward-same-level)
  74   (define-key outline-mode-prefix-map "\C-t" 'hide-body)
  75   (define-key outline-mode-prefix-map "\C-a" 'show-all)
  76   (define-key outline-mode-prefix-map "\C-c" 'hide-entry)
  77   (define-key outline-mode-prefix-map "\C-e" 'show-entry)
  78   (define-key outline-mode-prefix-map "\C-l" 'hide-leaves)
  79   (define-key outline-mode-prefix-map "\C-k" 'show-branches)
  80   (define-key outline-mode-prefix-map "\C-q" 'hide-sublevels)
  81   (define-key outline-mode-prefix-map "\C-o" 'hide-other))
  82
  83 (defvar outline-mode-menu-bar-map nil)
  84 (if outline-mode-menu-bar-map
  85     nil
  86   (setq outline-mode-menu-bar-map (make-sparse-keymap))
  87
  88   (define-key outline-mode-menu-bar-map [hide]
  89     (cons "Hide" (make-sparse-keymap "Hide")))
  90
  91   (define-key outline-mode-menu-bar-map [hide hide-other]
  92     '("Hide Other" . hide-other))
  93   (define-key outline-mode-menu-bar-map [hide hide-sublevels]
  94     '("Hide Sublevels" . hide-sublevels))
  95   (define-key outline-mode-menu-bar-map [hide hide-subtree]
  96     '("Hide Subtree" . hide-subtree))
  97   (define-key outline-mode-menu-bar-map [hide hide-entry]
  98     '("Hide Entry" . hide-entry))
  99   (define-key outline-mode-menu-bar-map [hide hide-body]
 100     '("Hide Body" . hide-body))
 101   (define-key outline-mode-menu-bar-map [hide hide-leaves]
 102     '("Hide Leaves" . hide-leaves))
 103
 104   (define-key outline-mode-menu-bar-map [show]
 105     (cons "Show" (make-sparse-keymap "Show")))
 106
 107   (define-key outline-mode-menu-bar-map [show show-subtree]
 108     '("Show Subtree" . show-subtree))
 109   (define-key outline-mode-menu-bar-map [show show-children]
 110     '("Show Children" . show-children))
 111   (define-key outline-mode-menu-bar-map [show show-branches]
 112     '("Show Branches" . show-branches))
 113   (define-key outline-mode-menu-bar-map [show show-entry]
 114     '("Show Entry" . show-entry))
 115   (define-key outline-mode-menu-bar-map [show show-all]
 116     '("Show All" . show-all))
 117
 118   (define-key outline-mode-menu-bar-map [headings]
 119     (cons "Headings" (make-sparse-keymap "Headings")))
 120
 121   (define-key outline-mode-menu-bar-map [headings copy]
 122     '(menu-item "Copy to kill ring" outline-headers-as-kill
 123                 :enable mark-active))
 124   (define-key outline-mode-menu-bar-map [headings outline-backward-same-level]
 125     '("Previous Same Level" . outline-backward-same-level))
 126   (define-key outline-mode-menu-bar-map [headings outline-forward-same-level]
 127     '("Next Same Level" . outline-forward-same-level))
 128   (define-key outline-mode-menu-bar-map [headings outline-previous-visible-heading]
 129     '("Previous" . outline-previous-visible-heading))
 130   (define-key outline-mode-menu-bar-map [headings outline-next-visible-heading]
 131     '("Next" . outline-next-visible-heading))
 132   (define-key outline-mode-menu-bar-map [headings outline-up-heading]
 133     '("Up" . outline-up-heading)))
 134
 135 (defvar outline-mode-map nil "")
 136
 137 (if outline-mode-map
 138     nil
 139   (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map))
 140   (define-key outline-mode-map "\C-c" outline-mode-prefix-map)
 141   (define-key outline-mode-map [menu-bar] outline-mode-menu-bar-map))
 142
 143 (defcustom outline-minor-mode nil
 144   "Non-nil if using Outline mode as a minor mode of some other mode."
 145   :type 'boolean
 146   :group 'outlines)
 147 (make-variable-buffer-local 'outline-minor-mode)
 148 (or (assq 'outline-minor-mode minor-mode-alist)
 149     (setq minor-mode-alist (append minor-mode-alist
 150                                    (list '(outline-minor-mode " Outl")))))
 151
 152 (defvar outline-font-lock-keywords
 153   '(;;
 154     ;; Highlight headings according to the level.
 155     (eval . (list (concat "^" outline-regexp ".+")
 156                   0 '(or (cdr (assq (outline-font-lock-level)
 157                                     '((1 . font-lock-function-name-face)
 158                                       (2 . font-lock-variable-name-face)
 159                                       (3 . font-lock-keyword-face)
 160                                       (4 . font-lock-builtin-face)
 161                                       (5 . font-lock-comment-face)
 162                                       (6 . font-lock-constant-face)
 163                                       (7 . font-lock-type-face)
 164                                       (8 . font-lock-string-face))))
 165                          font-lock-warning-face)
 166                   nil t)))
 167   "Additional expressions to highlight in Outline mode.")
 168
 169 (defun outline-font-lock-level ()
 170   (let ((count 1))
 171     (save-excursion
 172       (outline-back-to-heading t)
 173       (condition-case nil
 174           (while (not (bobp))
 175             (outline-up-heading-all 1)
 176             (setq count (1+ count)))
 177         (error)))
 178     count))
 179
 180 (defvar outline-view-change-hook nil
 181   "Normal hook to be run after outline visibility changes.")
 182
 183 ;;;###autoload
 184 (defun outline-mode ()
 185   "Set major mode for editing outlines with selective display.
 186 Headings are lines which start with asterisks: one for major headings,
 187 two for subheadings, etc.  Lines not starting with asterisks are body lines.
 188
 189 Body text or subheadings under a heading can be made temporarily
 190 invisible, or visible again.  Invisible lines are attached to the end
 191 of the heading, so they move with it, if the line is killed and yanked
 192 back.  A heading with text hidden under it is marked with an ellipsis (...).
 193
 194 Commands:\\<outline-mode-map>
 195 \\[outline-next-visible-heading]   outline-next-visible-heading      move by visible headings
 196 \\[outline-previous-visible-heading]   outline-previous-visible-heading
 197 \\[outline-forward-same-level]   outline-forward-same-level        similar but skip subheadings
 198 \\[outline-backward-same-level]   outline-backward-same-level
 199 \\[outline-up-heading]   outline-up-heading                 move from subheading to heading
 200
 201 \\[hide-body]   make all text invisible (not headings).
 202 \\[show-all]    make everything in buffer visible.
 203
 204 The remaining commands are used when point is on a heading line.
 205 They apply to some of the body or subheadings of that heading.
 206 \\[hide-subtree]   hide-subtree make body and subheadings invisible.
 207 \\[show-subtree]   show-subtree make body and subheadings visible.
 208 \\[show-children]   show-children       make direct subheadings visible.
 209                  No effect on body, or subheadings 2 or more levels down.
 210                  With arg N, affects subheadings N levels down.
 211 \\[hide-entry]     make immediately following body invisible.
 212 \\[show-entry]     make it visible.
 213 \\[hide-leaves]    make body under heading and under its subheadings invisible.
 214                      The subheadings remain visible.
 215 \\[show-branches]  make all subheadings at all levels visible.
 216
 217 The variable `outline-regexp' can be changed to control what is a heading.
 218 A line is a heading if `outline-regexp' matches something at the
 219 beginning of the line.  The longer the match, the deeper the level.
 220
 221 Turning on outline mode calls the value of `text-mode-hook' and then of
 222 `outline-mode-hook', if they are non-nil."
 223   (interactive)
 224   (kill-all-local-variables)
 225   (use-local-map outline-mode-map)
 226   (setq mode-name "Outline")
 227   (setq major-mode 'outline-mode)
 228   (define-abbrev-table 'text-mode-abbrev-table ())
 229   (setq local-abbrev-table text-mode-abbrev-table)
 230   (set-syntax-table text-mode-syntax-table)
 231   (make-local-variable 'line-move-ignore-invisible)
 232   (setq line-move-ignore-invisible t)
 233   ;; Cause use of ellipses for invisible text.
 234   (add-to-invisibility-spec '(outline . t))
 235   (make-local-variable 'paragraph-start)
 236   (setq paragraph-start (concat paragraph-start "\\|\\("
 237                                 outline-regexp "\\)"))
 238   ;; Inhibit auto-filling of header lines.
 239   (make-local-variable 'auto-fill-inhibit-regexp)
 240   (setq auto-fill-inhibit-regexp outline-regexp)
 241   (make-local-variable 'paragraph-separate)
 242   (setq paragraph-separate (concat paragraph-separate "\\|\\("
 243                                    outline-regexp "\\)"))
 244   (make-local-variable 'font-lock-defaults)
 245   (setq font-lock-defaults '(outline-font-lock-keywords t))
 246   (make-local-variable 'change-major-mode-hook)
 247   (setq imenu-generic-expression
 248         (list (list nil (concat outline-regexp ".*$") 0)))
 249   (add-hook 'change-major-mode-hook 'show-all)
 250   (run-hooks 'text-mode-hook 'outline-mode-hook))
 251
 252 (defcustom outline-minor-mode-prefix "\C-c@"
 253   "*Prefix key to use for Outline commands in Outline minor mode.
 254 The value of this variable is checked as part of loading Outline mode.
 255 After that, changing the prefix key requires manipulating keymaps."
 256   :type 'string
 257   :group 'outlines)
 258
 259 (defvar outline-minor-mode-map nil)
 260 (if outline-minor-mode-map
 261     nil
 262   (setq outline-minor-mode-map (make-sparse-keymap))
 263   (define-key outline-minor-mode-map [menu-bar]
 264     outline-mode-menu-bar-map)
 265   (define-key outline-minor-mode-map outline-minor-mode-prefix
 266     outline-mode-prefix-map))
 267
 268 (or (assq 'outline-minor-mode minor-mode-map-alist)
 269     (setq minor-mode-map-alist
 270           (cons (cons 'outline-minor-mode outline-minor-mode-map)
 271                 minor-mode-map-alist)))
 272
 273 ;;;###autoload
 274 (defun outline-minor-mode (&optional arg)
 275   "Toggle Outline minor mode.
 276 With arg, turn Outline minor mode on if arg is positive, off otherwise.
 277 See the command `outline-mode' for more information on this mode."
 278   (interactive "P")
 279   (setq outline-minor-mode
 280         (if (null arg) (not outline-minor-mode)
 281           (> (prefix-numeric-value arg) 0)))
 282   (if outline-minor-mode
 283       (progn
 284         (make-local-hook 'change-major-mode-hook)
 285         ;; Turn off this mode if we change major modes.
 286         (add-hook 'change-major-mode-hook
 287                   (lambda () (outline-minor-mode -1))
 288                   nil t)
 289         (make-local-variable 'line-move-ignore-invisible)
 290         (setq line-move-ignore-invisible t)
 291         ;; Cause use of ellipses for invisible text.
 292         (add-to-invisibility-spec '(outline . t))
 293         (run-hooks 'outline-minor-mode-hook))
 294     (setq line-move-ignore-invisible nil)
 295     ;; Cause use of ellipses for invisible text.
 296     (remove-from-invisibility-spec '(outline . t)))
 297   ;; When turning off outline mode, get rid of any outline hiding.
 298   (or outline-minor-mode
 299       (show-all))
 300   (force-mode-line-update))
 301 \f
 302 (defcustom outline-level 'outline-level
 303   "*Function of no args to compute a header's nesting level in an outline.
 304 It can assume point is at the beginning of a header line."
 305   :type 'function
 306   :group 'outlines)
 307
 308 ;; This used to count columns rather than characters, but that made ^L
 309 ;; appear to be at level 2 instead of 1.  Columns would be better for
 310 ;; tab handling, but the default regexp doesn't use tabs, and anyone
 311 ;; who changes the regexp can also redefine the outline-level variable
 312 ;; as appropriate.
 313 (defun outline-level ()
 314   "Return the depth to which a statement is nested in the outline.
 315 Point must be at the beginning of a header line.  This is actually
 316 the number of characters that `outline-regexp' matches."
 317   (save-excursion
 318     (looking-at outline-regexp)
 319     (- (match-end 0) (match-beginning 0))))
 320
 321 (defun outline-next-preface ()
 322   "Skip forward to just before the next heading line.
 323 If there's no following heading line, stop before the newline
 324 at the end of the buffer."
 325   (if (re-search-forward (concat "\n\\(" outline-regexp "\\)")
 326                          nil 'move)
 327       (goto-char (match-beginning 0)))
 328   (if (and (bolp) (not (bobp)))
 329       (forward-char -1)))
 330
 331 (defun outline-next-heading ()
 332   "Move to the next (possibly invisible) heading line."
 333   (interactive)
 334   (if (re-search-forward (concat "\n\\(" outline-regexp "\\)")
 335                          nil 'move)
 336       (goto-char (1+ (match-beginning 0)))))
 337
 338 (defun outline-previous-heading ()
 339   "Move to the previous (possibly invisible) heading line."
 340   (interactive)
 341   (re-search-backward (concat "^\\(" outline-regexp "\\)")
 342                       nil 'move))
 343
 344 (defsubst outline-visible ()
 345   "Non-nil if the character after point is visible."
 346   (not (get-char-property (point) 'invisible)))
 347
 348 (defun outline-back-to-heading (&optional invisible-ok)
 349   "Move to previous heading line, or beg of this line if it's a heading.
 350 Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
 351   (beginning-of-line)
 352   (or (outline-on-heading-p invisible-ok)
 353       (let (found)
 354         (save-excursion
 355           (while (not found)
 356             (or (re-search-backward (concat "^\\(" outline-regexp "\\)")
 357                                     nil t)
 358                 (error "before first heading"))
 359             (setq found (and (or invisible-ok (outline-visible)) (point)))))
 360         (goto-char found)
 361         found)))
 362
 363 (defun outline-on-heading-p (&optional invisible-ok)
 364   "Return t if point is on a (visible) heading line.
 365 If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
 366   (save-excursion
 367     (beginning-of-line)
 368     (and (bolp) (or invisible-ok (outline-visible))
 369          (looking-at outline-regexp))))
 370
 371 (defun outline-end-of-heading ()
 372   (if (re-search-forward outline-heading-end-regexp nil 'move)
 373       (forward-char -1)))
 374
 375 (defun outline-next-visible-heading (arg)
 376   "Move to the next visible heading line.
 377 With argument, repeats or can move backward if negative.
 378 A heading line is one that starts with a `*' (or that
 379 `outline-regexp' matches)."
 380   (interactive "p")
 381   (if (< arg 0)
 382       (beginning-of-line)
 383     (end-of-line))
 384   (while (and (not (bobp)) (< arg 0))
 385     (while (and (not (bobp))
 386                 (re-search-backward (concat "^\\(" outline-regexp "\\)")
 387                                     nil 'move)
 388                 (not (outline-visible))))
 389     (setq arg (1+ arg)))
 390   (while (and (not (eobp)) (> arg 0))
 391     (while (and (not (eobp))
 392                 (re-search-forward (concat "^\\(" outline-regexp "\\)")
 393                                    nil 'move)
 394                 (not (outline-visible))))
 395     (setq arg (1- arg)))
 396   (beginning-of-line))
 397
 398 (defun outline-previous-visible-heading (arg)
 399   "Move to the previous heading line.
 400 With argument, repeats or can move forward if negative.
 401 A heading line is one that starts with a `*' (or that
 402 `outline-regexp' matches)."
 403   (interactive "p")
 404   (outline-next-visible-heading (- arg)))
 405
 406 (defun outline-mark-subtree ()
 407   "Mark the current subtree in an outlined document.
 408 This puts point at the start of the current subtree, and mark at the end."
 409   (interactive)
 410   (let ((beg))
 411     (if (outline-on-heading-p)
 412         ;; we are already looking at a heading
 413         (beginning-of-line)
 414       ;; else go back to previous heading
 415       (outline-previous-visible-heading 1))
 416     (setq beg (point))
 417     (outline-end-of-subtree)
 418     (push-mark (point))
 419     (goto-char beg)))
 420 \f
 421 (defun outline-flag-region (from to flag)
 422   "Hides or shows lines from FROM to TO, according to FLAG.
 423 If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
 424   (let ((inhibit-read-only t))
 425     (save-excursion
 426       (goto-char from)
 427       (end-of-line)
 428       (outline-discard-overlays (point) to 'outline)
 429       (if flag
 430           (let ((o (make-overlay (point) to)))
 431             (overlay-put o 'invisible 'outline)
 432             (overlay-put o 'isearch-open-invisible
 433                          'outline-isearch-open-invisible)))))
 434   (run-hooks 'outline-view-change-hook))
 435
 436
 437 ;; Function to be set as an outline-isearch-open-invisible' property
 438 ;; to the overlay that makes the outline invisible (see
 439 ;; `outline-flag-region').
 440 (defun outline-isearch-open-invisible (overlay)
 441   (save-excursion
 442     (goto-char (overlay-start overlay))
 443     (show-entry)))
 444
 445
 446 ;; Exclude from the region BEG ... END all overlays
 447 ;; which have PROP as the value of the `invisible' property.
 448 ;; Exclude them by shrinking them to exclude BEG ... END,
 449 ;; or even by splitting them if necessary.
 450 ;; Overlays without such an `invisible' property are not touched.
 451 (defun outline-discard-overlays (beg end prop)
 452   (if (< end beg)
 453       (setq beg (prog1 end (setq end beg))))
 454   (save-excursion
 455     (let ((overlays (overlays-in beg end))
 456           o
 457           o1)
 458       (while overlays
 459         (setq o (car overlays))
 460         (if (eq (overlay-get o 'invisible) prop)
 461             ;; Either push this overlay outside beg...end
 462             ;; or split it to exclude beg...end
 463             ;; or delete it entirely (if it is contained in beg...end).
 464             (if (< (overlay-start o) beg)
 465                 (if (> (overlay-end o) end)
 466                     (progn
 467                       (setq o1 (outline-copy-overlay o))
 468                       (move-overlay o1 (overlay-start o1) beg)
 469                       (move-overlay o end (overlay-end o)))
 470                   (move-overlay o (overlay-start o) beg))
 471               (if (> (overlay-end o) end)
 472                   (move-overlay o end (overlay-end o))
 473                 (delete-overlay o))))
 474         (setq overlays (cdr overlays))))))
 475
 476 ;; Make a copy of overlay O, with the same beginning, end and properties.
 477 (defun outline-copy-overlay (o)
 478   (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
 479                           (overlay-buffer o)))
 480         (props (overlay-properties o)))
 481     (while props
 482       (overlay-put o1 (car props) (nth 1 props))
 483       (setq props (cdr (cdr props))))
 484     o1))
 485 \f
 486 (defun hide-entry ()
 487   "Hide the body directly following this heading."
 488   (interactive)
 489   (outline-back-to-heading)
 490   (outline-end-of-heading)
 491   (save-excursion
 492    (outline-flag-region (point) (progn (outline-next-preface) (point)) t)))
 493
 494 (defun show-entry ()
 495   "Show the body directly following this heading.
 496 Show the heading too, if it is currently invisible."
 497   (interactive)
 498   (save-excursion
 499     (outline-back-to-heading t)
 500     (outline-flag-region (1- (point))
 501                          (progn (outline-next-preface) (point)) nil)))
 502
 503 (defun hide-body ()
 504   "Hide all of buffer except headings."
 505   (interactive)
 506   (hide-region-body (point-min) (point-max)))
 507
 508 (defun hide-region-body (start end)
 509   "Hide all body lines in the region, but not headings."
 510   ;; Nullify the hook to avoid repeated calls to `outline-flag-region'
 511   ;; wasting lots of time running `lazy-lock-fontify-after-outline'
 512   ;; and run the hook finally.
 513   (let (outline-view-change-hook)
 514     (save-excursion
 515       (save-restriction
 516         (narrow-to-region start end)
 517         (goto-char (point-min))
 518         (if (outline-on-heading-p)
 519             (outline-end-of-heading))
 520         (while (not (eobp))
 521           (outline-flag-region (point)
 522                                (progn (outline-next-preface) (point)) t)
 523           (if (not (eobp))
 524               (progn
 525                 (forward-char
 526                  (if (looking-at "\n\n")
 527                      2 1))
 528                 (outline-end-of-heading)))))))
 529   (run-hooks 'outline-view-change-hook))
 530
 531 (defun show-all ()
 532   "Show all of the text in the buffer."
 533   (interactive)
 534   (outline-flag-region (point-min) (point-max) nil))
 535
 536 (defun hide-subtree ()
 537   "Hide everything after this heading at deeper levels."
 538   (interactive)
 539   (outline-flag-subtree t))
 540
 541 (defun hide-leaves ()
 542   "Hide all body after this heading at deeper levels."
 543   (interactive)
 544   (outline-back-to-heading)
 545   (outline-end-of-heading)
 546   (hide-region-body (point) (progn (outline-end-of-subtree) (point))))
 547
 548 (defun show-subtree ()
 549   "Show everything after this heading at deeper levels."
 550   (interactive)
 551   (outline-flag-subtree nil))
 552
 553 (defun hide-sublevels (levels)
 554   "Hide everything but the top LEVELS levels of headers, in whole buffer."
 555   (interactive "p")
 556   (if (< levels 1)
 557       (error "Must keep at least one level of headers"))
 558   (setq levels (1- levels))
 559   (let (outline-view-change-hook)
 560     (save-excursion
 561       (goto-char (point-min))
 562       ;; Keep advancing to the next top-level heading.
 563       (while (or (and (bobp) (outline-on-heading-p))
 564                  (outline-next-heading))
 565         (let ((end (save-excursion (outline-end-of-subtree) (point))))
 566           ;; Hide everything under that.
 567           (outline-flag-region (point) end t)
 568           ;; Show the first LEVELS levels under that.
 569           (if (> levels 0)
 570               (show-children levels))
 571           ;; Move to the next, since we already found it.
 572           (goto-char end)))))
 573   (run-hooks 'outline-view-change-hook))
 574
 575 (defun hide-other ()
 576   "Hide everything except current body and parent and top-level headings."
 577   (interactive)
 578   (hide-sublevels 1)
 579   (let (outline-view-change-hook)
 580     (save-excursion
 581       (outline-back-to-heading t)
 582       (show-entry)
 583       (while (condition-case nil (progn (outline-up-heading 1) t)
 584                (error nil))
 585         (outline-flag-region (1- (point))
 586                              (save-excursion (forward-line 1) (point))
 587                              nil))))
 588   (run-hooks 'outline-view-change-hook))
 589
 590 (defun outline-flag-subtree (flag)
 591   (save-excursion
 592     (outline-back-to-heading)
 593     (outline-end-of-heading)
 594     (outline-flag-region (point)
 595                           (progn (outline-end-of-subtree) (point))
 596                           flag)))
 597
 598 (defun outline-end-of-subtree ()
 599   (outline-back-to-heading)
 600   (let ((opoint (point))
 601         (first t)
 602         (level (funcall outline-level)))
 603     (while (and (not (eobp))
 604                 (or first (> (funcall outline-level) level)))
 605       (setq first nil)
 606       (outline-next-heading))
 607     (if (bolp)
 608         (progn
 609           ;; Go to end of line before heading
 610           (forward-char -1)
 611           (if (bolp)
 612               ;; leave blank line before heading
 613               (forward-char -1))))))
 614 \f
 615 (defun show-branches ()
 616   "Show all subheadings of this heading, but not their bodies."
 617   (interactive)
 618   (show-children 1000))
 619
 620 (defun show-children (&optional level)
 621   "Show all direct subheadings of this heading.
 622 Prefix arg LEVEL is how many levels below the current level should be shown.
 623 Default is enough to cause the following heading to appear."
 624   (interactive "P")
 625   (setq level
 626         (if level (prefix-numeric-value level)
 627           (save-excursion
 628             (outline-back-to-heading)
 629             (let ((start-level (funcall outline-level)))
 630               (outline-next-heading)
 631               (if (eobp)
 632                   1
 633                 (max 1 (- (funcall outline-level) start-level)))))))
 634   (let (outline-view-change-hook)
 635     (save-excursion
 636       (save-restriction
 637         (outline-back-to-heading)
 638         (setq level (+ level (funcall outline-level)))
 639         (narrow-to-region (point)
 640                           (progn (outline-end-of-subtree)
 641                                  (if (eobp) (point-max) (1+ (point)))))
 642         (goto-char (point-min))
 643         (while (and (not (eobp))
 644                     (progn
 645                       (outline-next-heading)
 646                       (not (eobp))))
 647           (if (<= (funcall outline-level) level)
 648               (save-excursion
 649                 (outline-flag-region (save-excursion
 650                                        (forward-char -1)
 651                                        (if (bolp)
 652                                            (forward-char -1))
 653                                        (point))
 654                                      (progn (outline-end-of-heading) (point))
 655                                      nil)))))))
 656   (run-hooks 'outline-view-change-hook))
 657 \f
 658 (defun outline-up-heading-all (arg)
 659   "Move to the heading line of which the present line is a subheading.
 660 This function considers both visible and invisible heading lines.
 661 With argument, move up ARG levels."
 662   (outline-back-to-heading t)
 663   (if (eq (funcall outline-level) 1)
 664       (error "Already at top level of the outline"))
 665   (while (and (> (funcall outline-level) 1)
 666               (> arg 0)
 667               (not (bobp)))
 668     (let ((present-level (funcall outline-level)))
 669       (while (and (not (< (funcall outline-level) present-level))
 670                   (not (bobp)))
 671         (outline-previous-heading))
 672       (setq arg (- arg 1)))))
 673
 674 (defun outline-up-heading (arg)
 675   "Move to the visible heading line of which the present line is a subheading.
 676 With argument, move up ARG levels."
 677   (interactive "p")
 678   (outline-back-to-heading)
 679   (if (eq (funcall outline-level) 1)
 680       (error "Already at top level of the outline"))
 681   (while (and (> (funcall outline-level) 1)
 682               (> arg 0)
 683               (not (bobp)))
 684     (let ((present-level (funcall outline-level)))
 685       (while (and (not (< (funcall outline-level) present-level))
 686                   (not (bobp)))
 687         (outline-previous-visible-heading 1))
 688       (setq arg (- arg 1)))))
 689
 690 (defun outline-forward-same-level (arg)
 691   "Move forward to the ARG'th subheading at same level as this one.
 692 Stop at the first and last subheadings of a superior heading."
 693   (interactive "p")
 694   (outline-back-to-heading)
 695   (while (> arg 0)
 696     (let ((point-to-move-to (save-excursion
 697                               (outline-get-next-sibling))))
 698       (if point-to-move-to
 699           (progn
 700             (goto-char point-to-move-to)
 701             (setq arg (1- arg)))
 702         (progn
 703           (setq arg 0)
 704           (error "No following same-level heading"))))))
 705
 706 (defun outline-get-next-sibling ()
 707   "Move to next heading of the same level, and return point or nil if none."
 708   (let ((level (funcall outline-level)))
 709     (outline-next-visible-heading 1)
 710     (while (and (> (funcall outline-level) level)
 711                 (not (eobp)))
 712       (outline-next-visible-heading 1))
 713     (if (< (funcall outline-level) level)
 714         nil
 715       (point))))
 716
 717 (defun outline-backward-same-level (arg)
 718   "Move backward to the ARG'th subheading at same level as this one.
 719 Stop at the first and last subheadings of a superior heading."
 720   (interactive "p")
 721   (outline-back-to-heading)
 722   (while (> arg 0)
 723     (let ((point-to-move-to (save-excursion
 724                               (outline-get-last-sibling))))
 725       (if point-to-move-to
 726           (progn
 727             (goto-char point-to-move-to)
 728             (setq arg (1- arg)))
 729         (progn
 730           (setq arg 0)
 731           (error "No previous same-level heading"))))))
 732
 733 (defun outline-get-last-sibling ()
 734   "Move to previous heading of the same level, and return point or nil if none."
 735   (let ((level (funcall outline-level)))
 736     (outline-previous-visible-heading 1)
 737     (while (and (> (funcall outline-level) level)
 738                 (not (bobp)))
 739       (outline-previous-visible-heading 1))
 740     (if (< (funcall outline-level) level)
 741         nil
 742         (point))))
 743 \f
 744 (defun outline-headers-as-kill (beg end)
 745   "Save the visible outline headers in region at the start of the kill ring.
 746
 747 Text shown between the headers isn't copied.  Two newlines are
 748 inserted between saved headers.  Yanking the result may be a
 749 convenient way to make a table of contents of the buffer."
 750   (interactive "r")
 751   (save-excursion
 752     (save-restriction
 753       (narrow-to-region beg end)
 754       (goto-char (point-min))
 755       (let ((buffer (current-buffer))
 756             start end)
 757         (with-temp-buffer
 758           (with-current-buffer buffer
 759             ;; Boundary condition: starting on heading:
 760             (when (outline-on-heading-p)
 761               (outline-back-to-heading)
 762               (setq start (point)
 763                     end (progn (outline-end-of-heading)
 764                                (point)))
 765               (insert-buffer-substring buffer start end)
 766               (insert "\n\n")))
 767           (let ((temp-buffer (current-buffer)))
 768             (with-current-buffer buffer
 769               (while (outline-next-heading)
 770                 (when (outline-visible)
 771                   (setq start (point)
 772                         end (progn (outline-end-of-heading) (point)))
 773                   (with-current-buffer temp-buffer
 774                     (insert-buffer-substring buffer start end)
 775                     (insert "\n\n"))))))
 776           (kill-new (buffer-string)))))))
 777
 778 (provide 'outline)
 779 (provide 'noutline)
 780
 781 ;;; outline.el ends here