xemacs/noutline.el

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