code.delx.au - gnu-emacs/blob - lisp/textmodes/ooutline.el

   1 ;;; outline.el --- outline mode commands for Emacs
   2
   3 ;; Copyright (C) 1986, 1993 Free Software Foundation, Inc.
   4
   5 ;; 7-Feb-94     Kevin Broadey
   6 ;; Fix show-children so it doesn't try to narrow to (1+ (point-max)) when
   7 ;; exposing the last level-n header in the buffer.
   8 ;;
   9 ;; Maintainer: FSF
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This package is a major mode for editing outline-format documents.
  30 ;; An outline can be `abstracted' to show headers at any given level,
  31 ;; with all stuff below hidden.  See the Emacs manual for details.
  32
  33 ;;; Code:
  34
  35 ;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS.
  36
  37 (defvar outline-regexp "[*\^l]+"
  38   "*Regular expression to match the beginning of a heading.
  39 Any line whose beginning matches this regexp is considered to start a heading.
  40 The recommended way to set this is with a Local Variables: list
  41 in the file it applies to.  See also outline-heading-end-regexp.")
  42
  43 (defvar outline-heading-end-regexp "[\n\^M]"
  44   "*Regular expression to match the end of a heading line.
  45 You can assume that point is at the beginning of a heading when this
  46 regexp is searched for.  The heading ends at the end of the match.
  47 The recommended way to set this is with a \"Local Variables:\" list
  48 in the file it applies to.")
  49
  50 (defvar outline-mode-map nil "")
  51
  52 (if outline-mode-map
  53     nil
  54   (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map))
  55   (define-key outline-mode-map "\C-c\C-n" 'outline-next-visible-heading)
  56   (define-key outline-mode-map "\C-c\C-p" 'outline-previous-visible-heading)
  57   (define-key outline-mode-map "\C-c\C-i" 'show-children)
  58   (define-key outline-mode-map "\C-c\C-s" 'show-subtree)
  59   (define-key outline-mode-map "\C-c\C-d" 'hide-subtree)
  60   (define-key outline-mode-map "\C-c\C-u" 'outline-up-heading)
  61   (define-key outline-mode-map "\C-c\C-f" 'outline-forward-same-level)
  62   (define-key outline-mode-map "\C-c\C-b" 'outline-backward-same-level)
  63   (define-key outline-mode-map "\C-c\C-t" 'hide-body)
  64   (define-key outline-mode-map "\C-c\C-a" 'show-all)
  65   (define-key outline-mode-map "\C-c\C-c" 'hide-entry)
  66   (define-key outline-mode-map "\C-c\C-e" 'show-entry)
  67   (define-key outline-mode-map "\C-c\C-l" 'hide-leaves)
  68   (define-key outline-mode-map "\C-c\C-k" 'show-branches)
  69   (define-key outline-mode-map "\C-c\C-q" 'outline-hide-sublevels)
  70   (define-key outline-mode-map "\C-c\C-o" 'outline-hide-other)
  71
  72   (define-key outline-mode-map [menu-bar hide]
  73     (cons "Hide" (make-sparse-keymap "Hide")))
  74
  75   (define-key outline-mode-map [menu-bar hide hide-other]
  76     '("Hide Other" . outline-hide-other))
  77   (define-key outline-mode-map [menu-bar hide hide-sublevels]
  78     '("Hide Sublevels" . outline-hide-sublevels))
  79   (define-key outline-mode-map [menu-bar hide hide-subtree]
  80     '("Hide Subtree" . hide-subtree))
  81   (define-key outline-mode-map [menu-bar hide hide-entry]
  82     '("Hide Entry" . hide-entry))
  83   (define-key outline-mode-map [menu-bar hide hide-body]
  84     '("Hide Body" . hide-body))
  85   (define-key outline-mode-map [menu-bar hide hide-leaves]
  86     '("Hide Leaves" . hide-leaves))
  87
  88   (define-key outline-mode-map [menu-bar show]
  89     (cons "Show" (make-sparse-keymap "Show")))
  90
  91   (define-key outline-mode-map [menu-bar show show-subtree]
  92     '("Show Subtree" . show-subtree))
  93   (define-key outline-mode-map [menu-bar show show-children]
  94     '("Show Children" . show-children))
  95   (define-key outline-mode-map [menu-bar show show-branches]
  96     '("Show Branches" . show-branches))
  97   (define-key outline-mode-map [menu-bar show show-entry]
  98     '("Show Entry" . show-entry))
  99   (define-key outline-mode-map [menu-bar show show-all]
 100     '("Show All" . show-all))
 101
 102   (define-key outline-mode-map [menu-bar headings]
 103     (cons "Headings" (make-sparse-keymap "Headings")))
 104
 105   (define-key outline-mode-map [menu-bar headings outline-backward-same-level]
 106     '("Previous Same Level" . outline-backward-same-level))
 107   (define-key outline-mode-map [menu-bar headings outline-forward-same-level]
 108     '("Next Same Level" . outline-forward-same-level))
 109   (define-key outline-mode-map [menu-bar headings outline-previous-visible-heading]
 110     '("Previous" . outline-previous-visible-heading))
 111   (define-key outline-mode-map [menu-bar headings outline-next-visible-heading]
 112     '("Next" . outline-next-visible-heading))
 113   (define-key outline-mode-map [menu-bar headings outline-up-heading]
 114     '("Up" . outline-up-heading)))
 115
 116 (defvar outline-minor-mode nil
 117   "Non-nil if using Outline mode as a minor mode of some other mode.")
 118 (make-variable-buffer-local 'outline-minor-mode)
 119 (put 'outline-minor-mode 'permanent-local t)
 120 (or (assq 'outline-minor-mode minor-mode-alist)
 121     (setq minor-mode-alist (append minor-mode-alist
 122                                    (list '(outline-minor-mode " Outl")))))
 123
 124 ;;;###autoload
 125 (defun outline-mode ()
 126   "Set major mode for editing outlines with selective display.
 127 Headings are lines which start with asterisks: one for major headings,
 128 two for subheadings, etc.  Lines not starting with asterisks are body lines.
 129
 130 Body text or subheadings under a heading can be made temporarily
 131 invisible, or visible again.  Invisible lines are attached to the end
 132 of the heading, so they move with it, if the line is killed and yanked
 133 back.  A heading with text hidden under it is marked with an ellipsis (...).
 134
 135 Commands:\\<outline-mode-map>
 136 \\[outline-next-visible-heading]   outline-next-visible-heading      move by visible headings
 137 \\[outline-previous-visible-heading]   outline-previous-visible-heading
 138 \\[outline-forward-same-level]   outline-forward-same-level        similar but skip subheadings
 139 \\[outline-backward-same-level]   outline-backward-same-level
 140 \\[outline-up-heading]   outline-up-heading                 move from subheading to heading
 141
 142 M-x hide-body   make all text invisible (not headings).
 143 M-x show-all    make everything in buffer visible.
 144
 145 The remaining commands are used when point is on a heading line.
 146 They apply to some of the body or subheadings of that heading.
 147 \\[hide-subtree]   hide-subtree make body and subheadings invisible.
 148 \\[show-subtree]   show-subtree make body and subheadings visible.
 149 \\[show-children]   show-children       make direct subheadings visible.
 150                  No effect on body, or subheadings 2 or more levels down.
 151                  With arg N, affects subheadings N levels down.
 152 M-x hide-entry     make immediately following body invisible.
 153 M-x show-entry     make it visible.
 154 M-x hide-leaves    make body under heading and under its subheadings invisible.
 155                      The subheadings remain visible.
 156 M-x show-branches  make all subheadings at all levels visible.
 157
 158 The variable `outline-regexp' can be changed to control what is a heading.
 159 A line is a heading if `outline-regexp' matches something at the
 160 beginning of the line.  The longer the match, the deeper the level.
 161
 162 Turning on outline mode calls the value of `text-mode-hook' and then of
 163 `outline-mode-hook', if they are non-nil."
 164   (interactive)
 165   (kill-all-local-variables)
 166   (setq selective-display t)
 167   (use-local-map outline-mode-map)
 168   (setq mode-name "Outline")
 169   (setq major-mode 'outline-mode)
 170   (define-abbrev-table 'text-mode-abbrev-table ())
 171   (setq local-abbrev-table text-mode-abbrev-table)
 172   (set-syntax-table text-mode-syntax-table)
 173   (make-local-variable 'paragraph-start)
 174   (setq paragraph-start (concat paragraph-start "\\|^\\("
 175                                 outline-regexp "\\)"))
 176   ;; Inhibit auto-filling of header lines.
 177   (make-local-variable 'auto-fill-inhibit-regexp)
 178   (setq auto-fill-inhibit-regexp outline-regexp)
 179   (make-local-variable 'paragraph-separate)
 180   (setq paragraph-separate (concat paragraph-separate "\\|^\\("
 181                                    outline-regexp "\\)"))
 182   (add-hook 'change-major-mode-hook 'show-all)
 183   (run-hooks 'text-mode-hook 'outline-mode-hook))
 184
 185 (defvar outline-minor-mode-prefix "\C-c\C-o"
 186   "*Prefix key to use for Outline commands in Outline minor mode.")
 187
 188 (defvar outline-minor-mode-map nil)
 189 (if outline-minor-mode-map
 190     nil
 191   (setq outline-minor-mode-map (make-sparse-keymap))
 192   (define-key outline-minor-mode-map [menu-bar]
 193     (lookup-key outline-mode-map [menu-bar]))
 194   (define-key outline-minor-mode-map outline-minor-mode-prefix
 195     (lookup-key outline-mode-map "\C-c")))
 196
 197 (or (assq 'outline-minor-mode minor-mode-map-alist)
 198     (setq minor-mode-map-alist
 199           (cons (cons 'outline-minor-mode outline-minor-mode-map)
 200                 minor-mode-map-alist)))
 201
 202 ;;;###autoload
 203 (defun outline-minor-mode (&optional arg)
 204   "Toggle Outline minor mode.
 205 With arg, turn Outline minor mode on if arg is positive, off otherwise.
 206 See the command `outline-mode' for more information on this mode."
 207   (interactive "P")
 208   (setq outline-minor-mode
 209         (if (null arg) (not outline-minor-mode)
 210           (> (prefix-numeric-value arg) 0)))
 211   (if outline-minor-mode
 212       (progn
 213         (setq selective-display t)
 214         (run-hooks 'outline-minor-mode-hook))
 215     (setq selective-display nil))
 216   ;; When turning off outline mode, get rid of any ^M's.
 217   (or outline-minor-mode
 218       (outline-flag-region (point-min) (point-max) ?\n))
 219   (set-buffer-modified-p (buffer-modified-p)))
 220 \f
 221 (defvar outline-level 'outline-level
 222   "Function of no args to compute a header's nesting level in an outline.
 223 It can assume point is at the beginning of a header line.")
 224
 225 (defun outline-level ()
 226   "Return the depth to which a statement is nested in the outline.
 227 Point must be at the beginning of a header line.  This is actually
 228 the column number of the end of what `outline-regexp matches'."
 229   (save-excursion
 230     (looking-at outline-regexp)
 231     (save-excursion (goto-char (match-end 0)) (current-column))))
 232
 233 (defun outline-next-preface ()
 234   "Skip forward to just before the next heading line."
 235   (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
 236                          nil 'move)
 237       (goto-char (match-beginning 0)))
 238   (if (memq (preceding-char) '(?\n ?\^M))
 239       (forward-char -1)))
 240
 241 (defun outline-next-heading ()
 242   "Move to the next (possibly invisible) heading line."
 243   (interactive)
 244   (if (re-search-forward (concat "[\n\^M]\\(" outline-regexp "\\)")
 245                          nil 'move)
 246       (goto-char (1+ (match-beginning 0)))))
 247
 248 (defun outline-back-to-heading ()
 249   "Move to previous (possibly invisible) heading line,
 250 or to the beginning of this line if it is a heading line."
 251   (beginning-of-line)
 252   (or (outline-on-heading-p)
 253       (re-search-backward (concat "^\\(" outline-regexp "\\)") nil 'move)))
 254
 255 (defun outline-on-heading-p ()
 256   "Return T if point is on a header line."
 257   (save-excursion
 258     (beginning-of-line)
 259     (and (eq (preceding-char) ?\n)
 260          (looking-at outline-regexp))))
 261
 262 (defun outline-end-of-heading ()
 263   (if (re-search-forward outline-heading-end-regexp nil 'move)
 264       (forward-char -1)))
 265
 266 (defun outline-next-visible-heading (arg)
 267   "Move to the next visible heading line.
 268 With argument, repeats or can move backward if negative.
 269 A heading line is one that starts with a `*' (or that
 270 `outline-regexp' matches)."
 271   (interactive "p")
 272   (if (< arg 0)
 273       (beginning-of-line)
 274     (end-of-line))
 275   (re-search-forward (concat "^\\(" outline-regexp "\\)") nil nil arg)
 276   (beginning-of-line))
 277
 278 (defun outline-previous-visible-heading (arg)
 279   "Move to the previous heading line.
 280 With argument, repeats or can move forward if negative.
 281 A heading line is one that starts with a `*' (or that
 282 `outline-regexp' matches)."
 283   (interactive "p")
 284   (outline-next-visible-heading (- arg)))
 285
 286 (defun outline-flag-region (from to flag)
 287   "Hides or shows lines from FROM to TO, according to FLAG.
 288 If FLAG is `\\n' (newline character) then text is shown,
 289 while if FLAG is `\\^M' (control-M) the text is hidden."
 290   (let (buffer-read-only)
 291     (subst-char-in-region from to
 292                           (if (= flag ?\n) ?\^M ?\n)
 293                           flag t)))
 294 \f
 295 (defun hide-entry ()
 296   "Hide the body directly following this heading."
 297   (interactive)
 298   (outline-back-to-heading)
 299   (outline-end-of-heading)
 300   (save-excursion
 301    (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\^M)))
 302
 303 (defun show-entry ()
 304   "Show the body directly following this heading."
 305   (interactive)
 306   (save-excursion
 307    (outline-flag-region (point) (progn (outline-next-preface) (point)) ?\n)))
 308
 309 (defun hide-body ()
 310   "Hide all of buffer except headings."
 311   (interactive)
 312   (hide-region-body (point-min) (point-max)))
 313
 314 (defun hide-region-body (start end)
 315   "Hide all body lines in the region, but not headings."
 316   (save-excursion
 317     (save-restriction
 318       (narrow-to-region start end)
 319       (goto-char (point-min))
 320       (if (outline-on-heading-p)
 321           (outline-end-of-heading))
 322       (while (not (eobp))
 323         (outline-flag-region (point)
 324                              (progn (outline-next-preface) (point)) ?\^M)
 325         (if (not (eobp))
 326             (progn
 327               (forward-char
 328                (if (looking-at "[\n\^M][\n\^M]")
 329                    2 1))
 330               (outline-end-of-heading)))))))
 331
 332 (defun show-all ()
 333   "Show all of the text in the buffer."
 334   (interactive)
 335   (outline-flag-region (point-min) (point-max) ?\n))
 336
 337 (defun hide-subtree ()
 338   "Hide everything after this heading at deeper levels."
 339   (interactive)
 340   (outline-flag-subtree ?\^M))
 341
 342 (defun hide-leaves ()
 343   "Hide all body after this heading at deeper levels."
 344   (interactive)
 345   (outline-back-to-heading)
 346   (outline-end-of-heading)
 347   (hide-region-body (point) (progn (outline-end-of-subtree) (point))))
 348
 349 (defun show-subtree ()
 350   "Show everything after this heading at deeper levels."
 351   (interactive)
 352   (outline-flag-subtree ?\n))
 353
 354 (defun hide-sublevels (keep-levels)
 355   "Hide everything except the first KEEP-LEVEL headers."
 356   (interactive "p")
 357   (if (< keep-levels 1)
 358       (error "Must keep at least one level of headers"))
 359   (setq keep-levels (1- keep-levels))
 360   (save-excursion
 361     (goto-char (point-min))
 362     (hide-subtree)
 363     (show-children keep-levels)
 364     (condition-case err
 365       (while (outline-get-next-sibling)
 366         (hide-subtree)
 367         (show-children keep-levels))
 368       (error nil))))
 369
 370 (defun hide-other ()
 371   "Hide everything except for the current body and the parent headings."
 372   (interactive)
 373   (outline-hide-sublevels 1)
 374   (let ((last (point))
 375         (pos (point)))
 376     (while (save-excursion
 377              (and (re-search-backward "[\n\r]" nil t)
 378                   (eq (following-char) ?\r)))
 379       (save-excursion
 380         (beginning-of-line)
 381         (if (eq last (point))
 382             (progn
 383               (outline-next-heading)
 384               (outline-flag-region last (point) ?\n))
 385           (show-children)
 386           (setq last (point)))))))
 387
 388 (defun outline-flag-subtree (flag)
 389   (save-excursion
 390     (outline-back-to-heading)
 391     (outline-end-of-heading)
 392     (outline-flag-region (point)
 393                           (progn (outline-end-of-subtree) (point))
 394                           flag)))
 395
 396 (defun outline-end-of-subtree ()
 397   (outline-back-to-heading)
 398   (let ((opoint (point))
 399         (first t)
 400         (level (funcall outline-level)))
 401     (while (and (not (eobp))
 402                 (or first (> (funcall outline-level) level)))
 403       (setq first nil)
 404       (outline-next-heading))
 405     (if (eobp)
 406         nil
 407       ;; go to end of line before heading
 408       (forward-char -1)
 409       ;; skip preceding balnk line, if there is one
 410       (if (memq (preceding-char) '(?\n ?\^M))
 411           (forward-char -1)))))
 412 \f
 413 (defun show-branches ()
 414   "Show all subheadings of this heading, but not their bodies."
 415   (interactive)
 416   (show-children 1000))
 417
 418 (defun show-children (&optional level)
 419   "Show all direct subheadings of this heading.
 420 Prefix arg LEVEL is how many levels below the current level should be shown.
 421 Default is enough to cause the following heading to appear."
 422   (interactive "P")
 423   (setq level
 424         (if level (prefix-numeric-value level)
 425           (save-excursion
 426             (beginning-of-line)
 427             (let ((start-level (funcall outline-level)))
 428               (outline-next-heading)
 429               (if (eobp)
 430                   1
 431                 (max 1 (- (funcall outline-level) start-level)))))))
 432   (save-excursion
 433    (save-restriction
 434     (beginning-of-line)
 435     (setq level (+ level (funcall outline-level)))
 436     (narrow-to-region (point)
 437                       (progn (outline-end-of-subtree)
 438                              (if (eobp) (point-max) (1+ (point)))))
 439     (goto-char (point-min))
 440     (while (and (not (eobp))
 441                 (progn
 442                  (outline-next-heading)
 443                  (not (eobp))))
 444       (if (<= (funcall outline-level) level)
 445           (save-excursion
 446             (outline-flag-region (save-excursion
 447                                    (forward-char -1)
 448                                    (if (memq (preceding-char) '(?\n ?\^M))
 449                                        (forward-char -1))
 450                                    (point))
 451                                  (progn (outline-end-of-heading) (point))
 452                                  ?\n)))))))
 453 \f
 454 (defun outline-up-heading (arg)
 455   "Move to the heading line of which the present line is a subheading.
 456 With argument, move up ARG levels."
 457   (interactive "p")
 458   (outline-back-to-heading)
 459   (if (eq (funcall outline-level) 1)
 460       (error ""))
 461     (while (and (> (funcall outline-level) 1)
 462                 (> arg 0)
 463                 (not (bobp)))
 464       (let ((present-level (funcall outline-level)))
 465         (while (not (< (funcall outline-level) present-level))
 466           (outline-previous-visible-heading 1))
 467         (setq arg (- arg 1)))))
 468
 469 (defun outline-forward-same-level (arg)
 470   "Move forward to the ARG'th subheading from here of the same level as the
 471 present one. It stops at the first and last subheadings of a superior heading."
 472   (interactive "p")
 473   (outline-back-to-heading)
 474   (while (> arg 0)
 475     (let ((point-to-move-to (save-excursion
 476                               (outline-get-next-sibling))))
 477       (if point-to-move-to
 478           (progn
 479             (goto-char point-to-move-to)
 480             (setq arg (1- arg)))
 481         (progn
 482           (setq arg 0)
 483           (error ""))))))
 484
 485 (defun outline-get-next-sibling ()
 486   "Position the point at the next heading of the same level,
 487 and return that position or nil if it cannot be found."
 488   (let ((level (funcall outline-level)))
 489     (outline-next-visible-heading 1)
 490     (while (and (> (funcall outline-level) level)
 491                 (not (eobp)))
 492       (outline-next-visible-heading 1))
 493     (if (< (funcall outline-level) level)
 494         nil
 495       (point))))
 496
 497 (defun outline-backward-same-level (arg)
 498   "Move backward to the ARG'th subheading from here of the same level as the
 499 present one. It stops at the first and last subheadings of a superior heading."
 500   (interactive "p")
 501   (outline-back-to-heading)
 502   (while (> arg 0)
 503     (let ((point-to-move-to (save-excursion
 504                               (outline-get-last-sibling))))
 505       (if point-to-move-to
 506           (progn
 507             (goto-char point-to-move-to)
 508             (setq arg (1- arg)))
 509         (progn
 510           (setq arg 0)
 511           (error ""))))))
 512
 513 (defun outline-get-last-sibling ()
 514   "Position the point at the previous heading of the same level,
 515 and return that position or nil if it cannot be found."
 516   (let ((level (funcall outline-level)))
 517     (outline-previous-visible-heading 1)
 518     (while (and (> (funcall outline-level) level)
 519                 (not (bobp)))
 520       (outline-previous-visible-heading 1))
 521     (if (< (funcall outline-level) level)
 522         nil
 523         (point))))
 524
 525 (provide 'outline)
 526
 527 ;;; outline.el ends here