lisp/outline.el

   1 ;;; outline.el --- outline mode commands for Emacs
   2
   3 ;; Copyright (C) 1986, 93, 94, 95, 97, 2000, 01, 2004
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: outlines
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This package is a major mode for editing outline-format documents.
  29 ;; An outline can be `abstracted' to show headers at any given level,
  30 ;; with all stuff below hidden.  See the Emacs manual for details.
  31
  32 ;;; Todo:
  33
  34 ;; - subtree-terminators
  35 ;; - better handle comments before function bodies (i.e. heading)
  36 ;; - don't bother hiding whitespace
  37
  38 ;;; Code:
  39
  40 (defgroup outlines nil
  41   "Support for hierarchical outlining"
  42   :prefix "outline-"
  43   :group 'editing)
  44
  45 (defcustom outline-regexp "[*\^L]+"
  46   "*Regular expression to match the beginning of a heading.
  47 Any line whose beginning matches this regexp is considered to start a heading.
  48 Note that Outline mode only checks this regexp at the start of a line,
  49 so the regexp need not (and usually does not) start with `^'.
  50 The recommended way to set this is with a Local Variables: list
  51 in the file it applies to.  See also `outline-heading-end-regexp'."
  52   :type '(choice regexp (const nil))
  53   :group 'outlines)
  54
  55 (defcustom outline-heading-end-regexp "\n"
  56   "*Regular expression to match the end of a heading line.
  57 You can assume that point is at the beginning of a heading when this
  58 regexp is searched for.  The heading ends at the end of the match.
  59 The recommended way to set this is with a `Local Variables:' list
  60 in the file it applies to."
  61   :type 'regexp
  62   :group 'outlines)
  63
  64 (defvar outline-mode-prefix-map
  65   (let ((map (make-sparse-keymap)))
  66     (define-key map "@" 'outline-mark-subtree)
  67     (define-key map "\C-n" 'outline-next-visible-heading)
  68     (define-key map "\C-p" 'outline-previous-visible-heading)
  69     (define-key map "\C-i" 'show-children)
  70     (define-key map "\C-s" 'show-subtree)
  71     (define-key map "\C-d" 'hide-subtree)
  72     (define-key map "\C-u" 'outline-up-heading)
  73     (define-key map "\C-f" 'outline-forward-same-level)
  74     (define-key map "\C-b" 'outline-backward-same-level)
  75     (define-key map "\C-t" 'hide-body)
  76     (define-key map "\C-a" 'show-all)
  77     (define-key map "\C-c" 'hide-entry)
  78     (define-key map "\C-e" 'show-entry)
  79     (define-key map "\C-l" 'hide-leaves)
  80     (define-key map "\C-k" 'show-branches)
  81     (define-key map "\C-q" 'hide-sublevels)
  82     (define-key map "\C-o" 'hide-other)
  83     (define-key map "\C-^" 'outline-move-subtree-up)
  84     (define-key map "\C-v" 'outline-move-subtree-down)
  85     (define-key map [(control ?<)] 'outline-promote)
  86     (define-key map [(control ?>)] 'outline-demote)
  87     (define-key map "\C-m" 'outline-insert-heading)
  88     ;; Where to bind outline-cycle ?
  89     map))
  90
  91 (defvar outline-mode-menu-bar-map
  92   (let ((map (make-sparse-keymap)))
  93
  94     (define-key map [hide] (cons "Hide" (make-sparse-keymap "Hide")))
  95
  96     (define-key map [hide hide-other] '("Hide Other" . hide-other))
  97     (define-key map [hide hide-sublevels] '("Hide Sublevels" . hide-sublevels))
  98     (define-key map [hide hide-subtree] '("Hide Subtree" . hide-subtree))
  99     (define-key map [hide hide-entry] '("Hide Entry" . hide-entry))
 100     (define-key map [hide hide-body] '("Hide Body" . hide-body))
 101     (define-key map [hide hide-leaves] '("Hide Leaves" . hide-leaves))
 102
 103     (define-key map [show] (cons "Show" (make-sparse-keymap "Show")))
 104
 105     (define-key map [show show-subtree] '("Show Subtree" . show-subtree))
 106     (define-key map [show show-children] '("Show Children" . show-children))
 107     (define-key map [show show-branches] '("Show Branches" . show-branches))
 108     (define-key map [show show-entry] '("Show Entry" . show-entry))
 109     (define-key map [show show-all] '("Show All" . show-all))
 110
 111     (define-key map [headings]
 112       (cons "Headings" (make-sparse-keymap "Headings")))
 113
 114     (define-key map [headings demote-subtree]
 115       '(menu-item "Demote subtree" outline-demote))
 116     (define-key map [headings promote-subtree]
 117       '(menu-item "Promote subtree" outline-promote))
 118     (define-key map [headings move-subtree-down]
 119       '(menu-item "Move subtree down" outline-move-subtree-down))
 120     (define-key map [headings move-subtree-up]
 121       '(menu-item "Move subtree up" outline-move-subtree-up))
 122     (define-key map [headings copy]
 123       '(menu-item "Copy to kill ring" outline-headers-as-kill
 124         :enable mark-active))
 125     (define-key map [headings outline-insert-heading]
 126       '("New heading" . outline-insert-heading))
 127     (define-key map [headings outline-backward-same-level]
 128       '("Previous Same Level" . outline-backward-same-level))
 129     (define-key map [headings outline-forward-same-level]
 130       '("Next Same Level" . outline-forward-same-level))
 131     (define-key map [headings outline-previous-visible-heading]
 132       '("Previous" . outline-previous-visible-heading))
 133     (define-key map [headings outline-next-visible-heading]
 134       '("Next" . outline-next-visible-heading))
 135     (define-key map [headings outline-up-heading]
 136       '("Up" . outline-up-heading))
 137     map))
 138
 139 (defvar outline-minor-mode-menu-bar-map
 140   (let ((map (make-sparse-keymap)))
 141     (define-key map [outline]
 142       (cons "Outline"
 143             (nconc (make-sparse-keymap "Outline")
 144                    ;; Remove extra separator
 145                    (cdr
 146                     ;; Flatten the major mode's menus into a single menu.
 147                     (apply 'append
 148                            (mapcar (lambda (x)
 149                                      (if (consp x)
 150                                          ;; Add a separator between each
 151                                          ;; part of the unified menu.
 152                                          (cons '(--- "---") (cdr x))))
 153                                    outline-mode-menu-bar-map))))))
 154     map))
 155
 156
 157 (defvar outline-mode-map
 158   (let ((map (make-sparse-keymap)))
 159     (define-key map "\C-c" outline-mode-prefix-map)
 160     (define-key map [menu-bar] outline-mode-menu-bar-map)
 161     map))
 162
 163 (defvar outline-font-lock-keywords
 164   '(;;
 165     ;; Highlight headings according to the level.
 166     (eval . (list (concat "^\\(?:" outline-regexp "\\).+")
 167                   0 '(outline-font-lock-face) nil t)))
 168   "Additional expressions to highlight in Outline mode.")
 169
 170 (defface outline-1 '((t :inherit font-lock-function-name-face)) "Level 1.")
 171 (defface outline-2 '((t :inherit font-lock-variable-name-face)) "Level 2.")
 172 (defface outline-3 '((t :inherit font-lock-keyword-face)) "Level 3.")
 173 (defface outline-4 '((t :inherit font-lock-builtin-face)) "Level 4.")
 174 (defface outline-5 '((t :inherit font-lock-comment-face)) "Level 5.")
 175 (defface outline-6 '((t :inherit font-lock-constant-face)) "Level 6.")
 176 (defface outline-7 '((t :inherit font-lock-type-face)) "Level 7.")
 177 (defface outline-8 '((t :inherit font-lock-string-face)) "Level 8.")
 178
 179 (defvar outline-font-lock-faces
 180   [outline-1 outline-2 outline-3 outline-4
 181    outline-5 outline-6 outline-7 outline-8])
 182
 183 (defvar outline-font-lock-levels nil)
 184 (make-variable-buffer-local 'outline-font-lock-levels)
 185
 186 (defun outline-font-lock-face ()
 187   ;; (save-excursion
 188   ;;   (outline-back-to-heading t)
 189   ;;   (let* ((count 0)
 190   ;;       (start-level (funcall outline-level))
 191   ;;       (level start-level)
 192   ;;       face-level)
 193   ;;     (while (not (setq face-level
 194   ;;                    (if (or (bobp) (eq level 1)) 0
 195   ;;                      (cdr (assq level outline-font-lock-levels)))))
 196   ;;    (outline-up-heading 1 t)
 197   ;;    (setq count (1+ count))
 198   ;;    (setq level (funcall outline-level)))
 199   ;;     ;; Remember for later.
 200   ;;     (unless (zerop count)
 201   ;;    (setq face-level (+ face-level count))
 202   ;;    (push (cons start-level face-level) outline-font-lock-levels))
 203   ;;     (condition-case nil
 204   ;;      (aref outline-font-lock-faces face-level)
 205   ;;    (error font-lock-warning-face))))
 206   (save-excursion
 207     (goto-char (match-beginning 0))
 208     (looking-at outline-regexp)
 209     (condition-case nil
 210         (aref outline-font-lock-faces (1- (funcall outline-level)))
 211       (error font-lock-warning-face))))
 212
 213 (defvar outline-view-change-hook nil
 214   "Normal hook to be run after outline visibility changes.")
 215
 216 (defvar outline-mode-hook nil
 217   "*This hook is run when outline mode starts.")
 218
 219 ;;;###autoload
 220 (define-derived-mode outline-mode text-mode "Outline"
 221   "Set major mode for editing outlines with selective display.
 222 Headings are lines which start with asterisks: one for major headings,
 223 two for subheadings, etc.  Lines not starting with asterisks are body lines.
 224
 225 Body text or subheadings under a heading can be made temporarily
 226 invisible, or visible again.  Invisible lines are attached to the end
 227 of the heading, so they move with it, if the line is killed and yanked
 228 back.  A heading with text hidden under it is marked with an ellipsis (...).
 229
 230 Commands:\\<outline-mode-map>
 231 \\[outline-next-visible-heading]   outline-next-visible-heading      move by visible headings
 232 \\[outline-previous-visible-heading]   outline-previous-visible-heading
 233 \\[outline-forward-same-level]   outline-forward-same-level        similar but skip subheadings
 234 \\[outline-backward-same-level]   outline-backward-same-level
 235 \\[outline-up-heading]   outline-up-heading                 move from subheading to heading
 236
 237 \\[hide-body]   make all text invisible (not headings).
 238 \\[show-all]    make everything in buffer visible.
 239 \\[hide-sublevels]  make only the first N levels of headers visible.
 240
 241 The remaining commands are used when point is on a heading line.
 242 They apply to some of the body or subheadings of that heading.
 243 \\[hide-subtree]   hide-subtree make body and subheadings invisible.
 244 \\[show-subtree]   show-subtree make body and subheadings visible.
 245 \\[show-children]   show-children       make direct subheadings visible.
 246                  No effect on body, or subheadings 2 or more levels down.
 247                  With arg N, affects subheadings N levels down.
 248 \\[hide-entry]     make immediately following body invisible.
 249 \\[show-entry]     make it visible.
 250 \\[hide-leaves]    make body under heading and under its subheadings invisible.
 251                      The subheadings remain visible.
 252 \\[show-branches]  make all subheadings at all levels visible.
 253
 254 The variable `outline-regexp' can be changed to control what is a heading.
 255 A line is a heading if `outline-regexp' matches something at the
 256 beginning of the line.  The longer the match, the deeper the level.
 257
 258 Turning on outline mode calls the value of `text-mode-hook' and then of
 259 `outline-mode-hook', if they are non-nil."
 260   (make-local-variable 'line-move-ignore-invisible)
 261   (setq line-move-ignore-invisible t)
 262   ;; Cause use of ellipses for invisible text.
 263   (add-to-invisibility-spec '(outline . t))
 264   (set (make-local-variable 'paragraph-start)
 265        (concat paragraph-start "\\|\\(?:" outline-regexp "\\)"))
 266   ;; Inhibit auto-filling of header lines.
 267   (set (make-local-variable 'auto-fill-inhibit-regexp) outline-regexp)
 268   (set (make-local-variable 'paragraph-separate)
 269        (concat paragraph-separate "\\|\\(?:" outline-regexp "\\)"))
 270   (set (make-local-variable 'font-lock-defaults)
 271        '(outline-font-lock-keywords t nil nil backward-paragraph))
 272   (setq imenu-generic-expression
 273         (list (list nil (concat "^\\(?:" outline-regexp "\\).*$") 0)))
 274   (add-hook 'change-major-mode-hook 'show-all nil t))
 275
 276 (defcustom outline-minor-mode-prefix "\C-c@"
 277   "*Prefix key to use for Outline commands in Outline minor mode.
 278 The value of this variable is checked as part of loading Outline mode.
 279 After that, changing the prefix key requires manipulating keymaps."
 280   :type 'string
 281   :group 'outlines)
 282
 283 ;;;###autoload
 284 (define-minor-mode outline-minor-mode
 285   "Toggle Outline minor mode.
 286 With arg, turn Outline minor mode on if arg is positive, off otherwise.
 287 See the command `outline-mode' for more information on this mode."
 288   nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
 289                     (cons outline-minor-mode-prefix outline-mode-prefix-map))
 290   :group 'outlines
 291   (if outline-minor-mode
 292       (progn
 293         ;; Turn off this mode if we change major modes.
 294         (add-hook 'change-major-mode-hook
 295                   (lambda () (outline-minor-mode -1))
 296                   nil t)
 297         (set (make-local-variable 'line-move-ignore-invisible) t)
 298         ;; Cause use of ellipses for invisible text.
 299         (add-to-invisibility-spec '(outline . t)))
 300     (setq line-move-ignore-invisible nil)
 301     ;; Cause use of ellipses for invisible text.
 302     (remove-from-invisibility-spec '(outline . t))
 303     ;; When turning off outline mode, get rid of any outline hiding.
 304     (show-all)))
 305 \f
 306 (defvar outline-level 'outline-level
 307   "*Function of no args to compute a header's nesting level in an outline.
 308 It can assume point is at the beginning of a header line and that the match
 309 data reflects the `outline-regexp'.")
 310
 311 (defvar outline-heading-alist ()
 312   "Alist associating a heading for every possible level.
 313 Each entry is of the form (HEADING . LEVEL).
 314 This alist is used two ways: to find the heading corresponding to
 315 a given level and to find the level of a given heading.
 316 If a mode or document needs several sets of outline headings (for example
 317 numbered and unnumbered sections), list them set by set and sorted by level
 318 within each set.  For example in texinfo mode:
 319
 320      (setq outline-heading-alist
 321       '((\"@chapter\" . 2) (\"@section\" . 3) (\"@subsection\" . 4)
 322            (\"@subsubsection\" . 5)
 323         (\"@unnumbered\" . 2) (\"@unnumberedsec\" . 3)
 324            (\"@unnumberedsubsec\" . 4)  (\"@unnumberedsubsubsec\" . 5)
 325         (\"@appendix\" . 2) (\"@appendixsec\" . 3)...
 326            (\"@appendixsubsec\" . 4) (\"@appendixsubsubsec\" . 5) ..))
 327
 328 Instead of sorting the entries in each set, you can also separate the
 329 sets with nil.")
 330 (make-variable-buffer-local 'outline-heading-alist)
 331
 332 ;; This used to count columns rather than characters, but that made ^L
 333 ;; appear to be at level 2 instead of 1.  Columns would be better for
 334 ;; tab handling, but the default regexp doesn't use tabs, and anyone
 335 ;; who changes the regexp can also redefine the outline-level variable
 336 ;; as appropriate.
 337 (defun outline-level ()
 338   "Return the depth to which a statement is nested in the outline.
 339 Point must be at the beginning of a header line.
 340 This is actually either the level specified in `outline-heading-alist'
 341 or else the number of characters matched by `outline-regexp'."
 342   (or (cdr (assoc (match-string 0) outline-heading-alist))
 343       (- (match-end 0) (match-beginning 0))))
 344
 345 (defun outline-next-preface ()
 346   "Skip forward to just before the next heading line.
 347 If there's no following heading line, stop before the newline
 348 at the end of the buffer."
 349   (if (re-search-forward (concat "\n\\(?:" outline-regexp "\\)")
 350                          nil 'move)
 351       (goto-char (match-beginning 0)))
 352   (if (and (bolp) (not (bobp)))
 353       (forward-char -1)))
 354
 355 (defun outline-next-heading ()
 356   "Move to the next (possibly invisible) heading line."
 357   (interactive)
 358   ;; Make sure we don't match the heading we're at.
 359   (if (and (bolp) (not (eobp))) (forward-char 1))
 360   (if (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
 361                          nil 'move)
 362       (goto-char (match-beginning 0))))
 363
 364 (defun outline-previous-heading ()
 365   "Move to the previous (possibly invisible) heading line."
 366   (interactive)
 367   (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
 368                       nil 'move))
 369
 370 (defsubst outline-invisible-p (&optional pos)
 371   "Non-nil if the character after point is invisible."
 372   (get-char-property (or pos (point)) 'invisible))
 373
 374 (defun outline-visible ()
 375   (not (outline-invisible-p)))
 376 (make-obsolete 'outline-visible 'outline-invisible-p)
 377
 378 (defun outline-back-to-heading (&optional invisible-ok)
 379   "Move to previous heading line, or beg of this line if it's a heading.
 380 Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
 381   (beginning-of-line)
 382   (or (outline-on-heading-p invisible-ok)
 383       (let (found)
 384         (save-excursion
 385           (while (not found)
 386             (or (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
 387                                     nil t)
 388                 (error "before first heading"))
 389             (setq found (and (or invisible-ok (not (outline-invisible-p)))
 390                              (point)))))
 391         (goto-char found)
 392         found)))
 393
 394 (defun outline-on-heading-p (&optional invisible-ok)
 395   "Return t if point is on a (visible) heading line.
 396 If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
 397   (save-excursion
 398     (beginning-of-line)
 399     (and (bolp) (or invisible-ok (not (outline-invisible-p)))
 400          (looking-at outline-regexp))))
 401
 402 (defun outline-insert-heading ()
 403   "Insert a new heading at same depth at point."
 404   (interactive)
 405   (let ((head (save-excursion
 406                 (condition-case nil
 407                     (outline-back-to-heading)
 408                   (error (outline-next-heading)))
 409                 (if (eobp)
 410                     (or (caar outline-heading-alist) "")
 411                   (match-string 0)))))
 412     (unless (or (string-match "[ \t]\\'" head)
 413                 (not (string-match (concat "\\`\\(?:" outline-regexp "\\)")
 414                                    (concat head " "))))
 415       (setq head (concat head " ")))
 416     (unless (bolp) (end-of-line) (newline))
 417     (insert head)
 418     (unless (eolp)
 419       (save-excursion (newline-and-indent)))
 420     (run-hooks 'outline-insert-heading-hook)))
 421
 422 (defun outline-promote (&optional children)
 423   "Promote headings higher up the tree.
 424 If prefix argument CHILDREN is given, promote also all the children.
 425 If the region is active in `transient-mark-mode', promote all headings
 426 in the region."
 427   (interactive
 428    (list (if (and transient-mark-mode mark-active) 'region
 429            (outline-back-to-heading)
 430            (if current-prefix-arg nil 'subtree))))
 431   (cond
 432    ((eq children 'region)
 433     (outline-map-region 'outline-promote (region-beginning) (region-end)))
 434    (children
 435     (outline-map-region 'outline-promote
 436                         (point)
 437                         (save-excursion (outline-get-next-sibling) (point))))
 438    (t
 439     (outline-back-to-heading t)
 440     (let* ((head (match-string 0))
 441            (level (save-match-data (funcall outline-level)))
 442            (up-head (or (outline-head-from-level (1- level) head)
 443                         (save-excursion
 444                           (save-match-data
 445                             (outline-up-heading 1 t)
 446                             (match-string 0))))))
 447
 448       (unless (rassoc level outline-heading-alist)
 449         (push (cons head level) outline-heading-alist))
 450
 451       (replace-match up-head nil t)))))
 452
 453 (defun outline-demote (&optional children)
 454   "Demote headings lower down the tree.
 455 If prefix argument CHILDREN is given, demote also all the children.
 456 If the region is active in `transient-mark-mode', demote all headings
 457 in the region."
 458   (interactive
 459    (list (if (and transient-mark-mode mark-active) 'region
 460            (outline-back-to-heading)
 461            (if current-prefix-arg nil 'subtree))))
 462   (cond
 463    ((eq children 'region)
 464     (outline-map-region 'outline-demote (region-beginning) (region-end)))
 465    (children
 466     (outline-map-region 'outline-demote
 467                         (point)
 468                         (save-excursion (outline-get-next-sibling) (point))))
 469    (t
 470     (let* ((head (match-string 0))
 471            (level (save-match-data (funcall outline-level)))
 472            (down-head
 473             (or (outline-head-from-level (1+ level) head)
 474                 (save-excursion
 475                   (save-match-data
 476                     (while (and (progn (outline-next-heading) (not (eobp)))
 477                                 (<= (funcall outline-level) level)))
 478                     (when (eobp)
 479                       ;; Try again from the beginning of the buffer.
 480                       (goto-char (point-min))
 481                       (while (and (progn (outline-next-heading) (not (eobp)))
 482                                   (<= (funcall outline-level) level))))
 483                     (unless (eobp)
 484                       (looking-at outline-regexp)
 485                       (match-string 0))))
 486                 (save-match-data
 487                   ;; Bummer!! There is no lower heading in the buffer.
 488                   ;; Let's try to invent one by repeating the first char.
 489                   (let ((new-head (concat (substring head 0 1) head)))
 490                     (if (string-match (concat "\\`\\(?:" outline-regexp "\\)")
 491                                       new-head)
 492                         ;; Why bother checking that it is indeed lower level ?
 493                         new-head
 494                       ;; Didn't work: keep it as is so it's still a heading.
 495                       head))))))
 496
 497     (unless (rassoc level outline-heading-alist)
 498       (push (cons head level) outline-heading-alist))
 499     (replace-match down-head nil t)))))
 500
 501 (defun outline-head-from-level (level head &optional alist)
 502   "Get new heading with level LEVEL from ALIST.
 503 If there are no such entries, return nil.
 504 ALIST defaults to `outline-heading-alist'.
 505 Similar to (car (rassoc LEVEL ALIST)).
 506 If there are several different entries with same new level, choose
 507 the one with the smallest distance to the assocation of HEAD in the alist.
 508 This makes it possible for promotion to work in modes with several
 509 independent sets of headings (numbered, unnumbered, appendix...)"
 510   (unless alist (setq alist outline-heading-alist))
 511   (let ((l (rassoc level alist))
 512         ll h hl l2 l2l)
 513     (cond
 514      ((null l) nil)
 515      ;; If there's no HEAD after L, any other entry for LEVEL after L
 516      ;; can't be much better than L.
 517      ((null (setq h (assoc head (setq ll (memq l alist))))) (car l))
 518      ;; If there's no other entry for LEVEL, just keep L.
 519      ((null (setq l2 (rassoc level (cdr ll)))) (car l))
 520      ;; Now we have L, L2, and H: see if L2 seems better than L.
 521      ;; If H is after L2, L2 is better.
 522      ((memq h (setq l2l (memq l2 (cdr ll))))
 523       (outline-head-from-level level head l2l))
 524      ;; Now we have H between L and L2.
 525      ;; If there's a separator between L and H, prefer L2.
 526      ((memq h (memq nil ll))
 527       (outline-head-from-level level head l2l))
 528      ;; If there's a separator between L2 and H, prefer L.
 529      ((memq l2 (memq nil (setq hl (memq h ll)))) (car l))
 530      ;; No separator between L and L2, check the distance.
 531      ((< (* 2 (length hl)) (+ (length ll) (length l2l)))
 532       (outline-head-from-level level head l2l))
 533      ;; If all else fails, just keep L.
 534      (t (car l)))))
 535
 536 (defun outline-map-region (fun beg end)
 537   "Call FUN for every heading between BEG and END.
 538 When FUN is called, point is at the beginning of the heading and
 539 the match data is set appropriately."
 540   (save-excursion
 541     (setq end (copy-marker end))
 542     (goto-char beg)
 543     (when (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t)
 544       (goto-char (match-beginning 0))
 545       (funcall fun)
 546       (while (and (progn
 547                     (outline-next-heading)
 548                     (< (point) end))
 549                   (not (eobp)))
 550         (funcall fun)))))
 551
 552 ;; Vertical tree motion
 553
 554 (defun outline-move-subtree-up (&optional arg)
 555   "Move the currrent subtree up past ARG headlines of the same level."
 556   (interactive "p")
 557   (outline-move-subtree-down (- arg)))
 558
 559 (defun outline-move-subtree-down (&optional arg)
 560   "Move the currrent subtree down past ARG headlines of the same level."
 561   (interactive "p")
 562   (let ((re (concat "^\\(?:" outline-regexp "\\)"))
 563         (movfunc (if (> arg 0) 'outline-get-next-sibling
 564                    'outline-get-last-sibling))
 565         (ins-point (make-marker))
 566         (cnt (abs arg))
 567         beg end txt folded)
 568     ;; Select the tree
 569     (outline-back-to-heading)
 570     (setq beg (point))
 571     (save-match-data
 572       (save-excursion (outline-end-of-heading)
 573                       (setq folded (outline-invisible-p)))
 574       (outline-end-of-subtree))
 575     (if (= (char-after) ?\n) (forward-char 1))
 576     (setq end (point))
 577     ;; Find insertion point, with error handling
 578     (goto-char beg)
 579     (while (> cnt 0)
 580       (or (funcall movfunc)
 581           (progn (goto-char beg)
 582                  (error "Cannot move past superior level")))
 583       (setq cnt (1- cnt)))
 584     (if (> arg 0)
 585         ;; Moving forward - still need to move over subtree
 586         (progn (outline-end-of-subtree)
 587                (if (= (char-after) ?\n) (forward-char 1))))
 588     (move-marker ins-point (point))
 589     (insert (delete-and-extract-region beg end))
 590     (goto-char ins-point)
 591     (if folded (hide-subtree))
 592     (move-marker ins-point nil)))
 593
 594 (defun outline-end-of-heading ()
 595   (if (re-search-forward outline-heading-end-regexp nil 'move)
 596       (forward-char -1)))
 597
 598 (defun outline-next-visible-heading (arg)
 599   "Move to the next visible heading line.
 600 With argument, repeats or can move backward if negative.
 601 A heading line is one that starts with a `*' (or that
 602 `outline-regexp' matches)."
 603   (interactive "p")
 604   (if (< arg 0)
 605       (beginning-of-line)
 606     (end-of-line))
 607   (while (and (not (bobp)) (< arg 0))
 608     (while (and (not (bobp))
 609                 (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
 610                                     nil 'move)
 611                 (outline-invisible-p)))
 612     (setq arg (1+ arg)))
 613   (while (and (not (eobp)) (> arg 0))
 614     (while (and (not (eobp))
 615                 (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
 616                                    nil 'move)
 617                 (outline-invisible-p (match-beginning 0))))
 618     (setq arg (1- arg)))
 619   (beginning-of-line))
 620
 621 (defun outline-previous-visible-heading (arg)
 622   "Move to the previous heading line.
 623 With argument, repeats or can move forward if negative.
 624 A heading line is one that starts with a `*' (or that
 625 `outline-regexp' matches)."
 626   (interactive "p")
 627   (outline-next-visible-heading (- arg)))
 628
 629 (defun outline-mark-subtree ()
 630   "Mark the current subtree in an outlined document.
 631 This puts point at the start of the current subtree, and mark at the end."
 632   (interactive)
 633   (let ((beg))
 634     (if (outline-on-heading-p)
 635         ;; we are already looking at a heading
 636         (beginning-of-line)
 637       ;; else go back to previous heading
 638       (outline-previous-visible-heading 1))
 639     (setq beg (point))
 640     (outline-end-of-subtree)
 641     (push-mark (point))
 642     (goto-char beg)))
 643 \f
 644
 645 (put 'outline 'reveal-toggle-invisible 'outline-reveal-toggle-invisible)
 646 (defun outline-flag-region (from to flag)
 647   "Hide or show lines from FROM to TO, according to FLAG.
 648 If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
 649   (remove-overlays from to 'invisible 'outline)
 650   (when flag
 651     (let ((o (make-overlay from to)))
 652       (overlay-put o 'invisible 'outline)
 653       (overlay-put o 'isearch-open-invisible 'outline-isearch-open-invisible)))
 654   ;; Seems only used by lazy-lock.  I.e. obsolete.
 655   (run-hooks 'outline-view-change-hook))
 656
 657 (defun outline-reveal-toggle-invisible (o hidep)
 658   (save-excursion
 659     (goto-char (overlay-start o))
 660     (if hidep
 661         ;; When hiding the area again, we could just clean it up and let
 662         ;; reveal do the rest, by simply doing:
 663         ;; (remove-overlays (overlay-start o) (overlay-end o)
 664         ;;                  'invisible 'outline)
 665         ;;
 666         ;; That works fine as long as everything is in sync, but if the
 667         ;; structure of the document is changed while revealing parts of it,
 668         ;; the resulting behavior can be ugly.  I.e. we need to make
 669         ;; sure that we hide exactly a subtree.
 670         (progn
 671           (let ((end (overlay-end o)))
 672             (delete-overlay o)
 673             (while (progn
 674                      (hide-subtree)
 675                      (outline-next-visible-heading 1)
 676                      (and (not (eobp)) (< (point) end))))))
 677
 678       ;; When revealing, we just need to reveal sublevels.  If point is
 679       ;; inside one of the sublevels, reveal will call us again.
 680       ;; But we need to preserve the original overlay.
 681       (let ((o1 (copy-overlay o)))
 682         (overlay-put o 'invisible nil)  ;Show (most of) the text.
 683         (while (progn
 684                  (show-entry)
 685                  (show-children)
 686                  ;; Normally just the above is needed.
 687                  ;; But in odd cases, the above might fail to show anything.
 688                  ;; To avoid an infinite loop, we have to make sure that
 689                  ;; *something* gets shown.
 690                  (and (equal (overlay-start o) (overlay-start o1))
 691                       (< (point) (overlay-end o))
 692                       (= 0 (forward-line 1)))))
 693         ;; If still nothing was shown, just kill the damn thing.
 694         (when (equal (overlay-start o) (overlay-start o1))
 695           ;; I've seen it happen at the end of buffer.
 696           (delete-overlay o1))))))
 697
 698 ;; Function to be set as an outline-isearch-open-invisible' property
 699 ;; to the overlay that makes the outline invisible (see
 700 ;; `outline-flag-region').
 701 (defun outline-isearch-open-invisible (overlay)
 702   ;; We rely on the fact that isearch places point on the matched text.
 703   (show-entry))
 704 \f
 705 (defun hide-entry ()
 706   "Hide the body directly following this heading."
 707   (interactive)
 708   (outline-back-to-heading)
 709   (outline-end-of-heading)
 710   (save-excursion
 711     (outline-flag-region (point) (progn (outline-next-preface) (point)) t)))
 712
 713 (defun show-entry ()
 714   "Show the body directly following this heading.
 715 Show the heading too, if it is currently invisible."
 716   (interactive)
 717   (save-excursion
 718     (outline-back-to-heading t)
 719     (outline-flag-region (1- (point))
 720                          (progn (outline-next-preface) (point)) nil)))
 721
 722 (defun hide-body ()
 723   "Hide all of buffer except headings."
 724   (interactive)
 725   (hide-region-body (point-min) (point-max)))
 726
 727 (defun hide-region-body (start end)
 728   "Hide all body lines in the region, but not headings."
 729   ;; Nullify the hook to avoid repeated calls to `outline-flag-region'
 730   ;; wasting lots of time running `lazy-lock-fontify-after-outline'
 731   ;; and run the hook finally.
 732   (let (outline-view-change-hook)
 733     (save-excursion
 734       (save-restriction
 735         (narrow-to-region start end)
 736         (goto-char (point-min))
 737         (if (outline-on-heading-p)
 738             (outline-end-of-heading))
 739         (while (not (eobp))
 740           (outline-flag-region (point)
 741                                (progn (outline-next-preface) (point)) t)
 742           (unless (eobp)
 743             (forward-char (if (looking-at "\n\n") 2 1))
 744             (outline-end-of-heading))))))
 745   (run-hooks 'outline-view-change-hook))
 746
 747 (defun show-all ()
 748   "Show all of the text in the buffer."
 749   (interactive)
 750   (outline-flag-region (point-min) (point-max) nil))
 751
 752 (defun hide-subtree ()
 753   "Hide everything after this heading at deeper levels."
 754   (interactive)
 755   (outline-flag-subtree t))
 756
 757 (defun hide-leaves ()
 758   "Hide all body after this heading at deeper levels."
 759   (interactive)
 760   (outline-back-to-heading)
 761   (save-excursion
 762     (outline-end-of-heading)
 763     (hide-region-body (point) (progn (outline-end-of-subtree) (point)))))
 764
 765 (defun show-subtree ()
 766   "Show everything after this heading at deeper levels."
 767   (interactive)
 768   (outline-flag-subtree nil))
 769
 770 (defun outline-show-heading ()
 771   "Show the current heading and move to its end."
 772   (outline-flag-region (- (point)
 773                           (if (bobp) 0
 774                             (if (eq (char-before (1- (point))) ?\n)
 775                                 2 1)))
 776                        (progn (outline-end-of-heading) (point))
 777                        nil))
 778
 779 (defun hide-sublevels (levels)
 780   "Hide everything but the top LEVELS levels of headers, in whole buffer."
 781   (interactive "p")
 782   (if (< levels 1)
 783       (error "Must keep at least one level of headers"))
 784   (let (outline-view-change-hook)
 785     (save-excursion
 786       (goto-char (point-min))
 787       ;; Skip the prelude, if any.
 788       (unless (outline-on-heading-p t) (outline-next-heading))
 789       ;; First hide everything.
 790       (outline-flag-region (point) (point-max) t)
 791       ;; Then unhide the top level headers.
 792       (outline-map-region
 793        (lambda ()
 794          (if (<= (funcall outline-level) levels)
 795              (outline-show-heading)))
 796        (point) (point-max))))
 797   (run-hooks 'outline-view-change-hook))
 798
 799 (defun hide-other ()
 800   "Hide everything except current body and parent and top-level headings."
 801   (interactive)
 802   (hide-sublevels 1)
 803   (let (outline-view-change-hook)
 804     (save-excursion
 805       (outline-back-to-heading t)
 806       (show-entry)
 807       (while (condition-case nil (progn (outline-up-heading 1) (not (bobp)))
 808                (error nil))
 809         (outline-flag-region (1- (point))
 810                              (save-excursion (forward-line 1) (point))
 811                              nil))))
 812   (run-hooks 'outline-view-change-hook))
 813
 814 (defun outline-toggle-children ()
 815   "Show or hide the current subtree depending on its current state."
 816   (interactive)
 817   (outline-back-to-heading)
 818   (if (not (outline-invisible-p (line-end-position)))
 819       (hide-subtree)
 820     (show-children)
 821     (show-entry)))
 822
 823 (defun outline-flag-subtree (flag)
 824   (save-excursion
 825     (outline-back-to-heading)
 826     (outline-end-of-heading)
 827     (outline-flag-region (point)
 828                           (progn (outline-end-of-subtree) (point))
 829                           flag)))
 830
 831 (defun outline-end-of-subtree ()
 832   (outline-back-to-heading)
 833   (let ((opoint (point))
 834         (first t)
 835         (level (funcall outline-level)))
 836     (while (and (not (eobp))
 837                 (or first (> (funcall outline-level) level)))
 838       (setq first nil)
 839       (outline-next-heading))
 840     (if (bolp)
 841         (progn
 842           ;; Go to end of line before heading
 843           (forward-char -1)
 844           (if (bolp)
 845               ;; leave blank line before heading
 846               (forward-char -1))))))
 847 \f
 848 (defun show-branches ()
 849   "Show all subheadings of this heading, but not their bodies."
 850   (interactive)
 851   (show-children 1000))
 852
 853 (defun show-children (&optional level)
 854   "Show all direct subheadings of this heading.
 855 Prefix arg LEVEL is how many levels below the current level should be shown.
 856 Default is enough to cause the following heading to appear."
 857   (interactive "P")
 858   (setq level
 859         (if level (prefix-numeric-value level)
 860           (save-excursion
 861             (outline-back-to-heading)
 862             (let ((start-level (funcall outline-level)))
 863               (outline-next-heading)
 864               (if (eobp)
 865                   1
 866                 (max 1 (- (funcall outline-level) start-level)))))))
 867   (let (outline-view-change-hook)
 868     (save-excursion
 869       (outline-back-to-heading)
 870       (setq level (+ level (funcall outline-level)))
 871       (outline-map-region
 872        (lambda ()
 873          (if (<= (funcall outline-level) level)
 874              (outline-show-heading)))
 875        (point)
 876        (progn (outline-end-of-subtree)
 877               (if (eobp) (point-max) (1+ (point)))))))
 878   (run-hooks 'outline-view-change-hook))
 879
 880 \f
 881
 882 (defun outline-up-heading (arg &optional invisible-ok)
 883   "Move to the visible heading line of which the present line is a subheading.
 884 With argument, move up ARG levels.
 885 If INVISIBLE-OK is non-nil, also consider invisible lines."
 886   (interactive "p")
 887   (outline-back-to-heading invisible-ok)
 888   (let ((start-level (funcall outline-level)))
 889     (if (eq start-level 1)
 890         (error "Already at top level of the outline"))
 891     (while (and (> start-level 1) (> arg 0) (not (bobp)))
 892       (let ((level start-level))
 893         (while (not (or (< level start-level) (bobp)))
 894           (if invisible-ok
 895               (outline-previous-heading)
 896             (outline-previous-visible-heading 1))
 897           (setq level (funcall outline-level)))
 898         (setq start-level level))
 899       (setq arg (- arg 1))))
 900   (looking-at outline-regexp))
 901
 902 (defun outline-forward-same-level (arg)
 903   "Move forward to the ARG'th subheading at same level as this one.
 904 Stop at the first and last subheadings of a superior heading."
 905   (interactive "p")
 906   (outline-back-to-heading)
 907   (while (> arg 0)
 908     (let ((point-to-move-to (save-excursion
 909                               (outline-get-next-sibling))))
 910       (if point-to-move-to
 911           (progn
 912             (goto-char point-to-move-to)
 913             (setq arg (1- arg)))
 914         (progn
 915           (setq arg 0)
 916           (error "No following same-level heading"))))))
 917
 918 (defun outline-get-next-sibling ()
 919   "Move to next heading of the same level, and return point or nil if none."
 920   (let ((level (funcall outline-level)))
 921     (outline-next-visible-heading 1)
 922     (while (and (not (eobp)) (> (funcall outline-level) level))
 923       (outline-next-visible-heading 1))
 924     (if (or (eobp) (< (funcall outline-level) level))
 925         nil
 926       (point))))
 927
 928 (defun outline-backward-same-level (arg)
 929   "Move backward to the ARG'th subheading at same level as this one.
 930 Stop at the first and last subheadings of a superior heading."
 931   (interactive "p")
 932   (outline-back-to-heading)
 933   (while (> arg 0)
 934     (let ((point-to-move-to (save-excursion
 935                               (outline-get-last-sibling))))
 936       (if point-to-move-to
 937           (progn
 938             (goto-char point-to-move-to)
 939             (setq arg (1- arg)))
 940         (progn
 941           (setq arg 0)
 942           (error "No previous same-level heading"))))))
 943
 944 (defun outline-get-last-sibling ()
 945   "Move to previous heading of the same level, and return point or nil if none."
 946   (let ((level (funcall outline-level)))
 947     (outline-previous-visible-heading 1)
 948     (while (and (> (funcall outline-level) level)
 949                 (not (bobp)))
 950       (outline-previous-visible-heading 1))
 951     (if (< (funcall outline-level) level)
 952         nil
 953         (point))))
 954 \f
 955 (defun outline-headers-as-kill (beg end)
 956   "Save the visible outline headers in region at the start of the kill ring.
 957
 958 Text shown between the headers isn't copied.  Two newlines are
 959 inserted between saved headers.  Yanking the result may be a
 960 convenient way to make a table of contents of the buffer."
 961   (interactive "r")
 962   (save-excursion
 963     (save-restriction
 964       (narrow-to-region beg end)
 965       (goto-char (point-min))
 966       (let ((buffer (current-buffer))
 967             start end)
 968         (with-temp-buffer
 969           (with-current-buffer buffer
 970             ;; Boundary condition: starting on heading:
 971             (when (outline-on-heading-p)
 972               (outline-back-to-heading)
 973               (setq start (point)
 974                     end (progn (outline-end-of-heading)
 975                                (point)))
 976               (insert-buffer-substring buffer start end)
 977               (insert "\n\n")))
 978           (let ((temp-buffer (current-buffer)))
 979             (with-current-buffer buffer
 980               (while (outline-next-heading)
 981                 (unless (outline-invisible-p)
 982                   (setq start (point)
 983                         end (progn (outline-end-of-heading) (point)))
 984                   (with-current-buffer temp-buffer
 985                     (insert-buffer-substring buffer start end)
 986                     (insert "\n\n"))))))
 987           (kill-new (buffer-string)))))))
 988
 989 (provide 'outline)
 990 (provide 'noutline)
 991
 992 ;;; arch-tag: 1724410e-7d4d-4f46-b801-49e18171e874
 993 ;;; outline.el ends here