X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/00958fa2aa6b521f820b5baf3f3fc71176af8789..b36a53f4be733b326739fdebb2285d106eecbd06:/lisp/outline.el diff --git a/lisp/outline.el b/lisp/outline.el index 89e9e193e9..92e521afc9 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1,7 +1,7 @@ ;;; outline.el --- outline mode commands for Emacs -;; Copyright (C) 1986, 93, 94, 95, 97, 2000, 01, 2004 -;; Free Software Foundation, Inc. +;; Copyright (C) 1986, 1993, 1994, 1995, 1997, 2000, 2001, 2002, +;; 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: outlines @@ -10,7 +10,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -20,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -37,13 +37,16 @@ ;;; Code: +(defvar font-lock-warning-face) + + (defgroup outlines nil - "Support for hierarchical outlining" + "Support for hierarchical outlining." :prefix "outline-" :group 'editing) (defcustom outline-regexp "[*\^L]+" - "*Regular expression to match the beginning of a heading. + "Regular expression to match the beginning of a heading. Any line whose beginning matches this regexp is considered to start a heading. Note that Outline mode only checks this regexp at the start of a line, so the regexp need not (and usually does not) start with `^'. @@ -51,9 +54,10 @@ The recommended way to set this is with a Local Variables: list in the file it applies to. See also `outline-heading-end-regexp'." :type '(choice regexp (const nil)) :group 'outlines) +;;;###autoload(put 'outline-regexp 'safe-local-variable 'string-or-null-p) (defcustom outline-heading-end-regexp "\n" - "*Regular expression to match the end of a heading line. + "Regular expression to match the end of a heading line. You can assume that point is at the beginning of a heading when this regexp is searched for. The heading ends at the end of the match. The recommended way to set this is with a `Local Variables:' list @@ -167,14 +171,45 @@ in the file it applies to." 0 '(outline-font-lock-face) nil t))) "Additional expressions to highlight in Outline mode.") -(defface outline-1 '((t :inherit font-lock-function-name-face)) "Level 1.") -(defface outline-2 '((t :inherit font-lock-variable-name-face)) "Level 2.") -(defface outline-3 '((t :inherit font-lock-keyword-face)) "Level 3.") -(defface outline-4 '((t :inherit font-lock-builtin-face)) "Level 4.") -(defface outline-5 '((t :inherit font-lock-comment-face)) "Level 5.") -(defface outline-6 '((t :inherit font-lock-constant-face)) "Level 6.") -(defface outline-7 '((t :inherit font-lock-type-face)) "Level 7.") -(defface outline-8 '((t :inherit font-lock-string-face)) "Level 8.") +(defface outline-1 + '((t :inherit font-lock-function-name-face)) + "Level 1." + :group 'outlines) + +(defface outline-2 + '((t :inherit font-lock-variable-name-face)) + "Level 2." + :group 'outlines) + +(defface outline-3 + '((t :inherit font-lock-keyword-face)) + "Level 3." + :group 'outlines) + +(defface outline-4 + '((t :inherit font-lock-builtin-face)) + "Level 4." + :group 'outlines) + +(defface outline-5 + '((t :inherit font-lock-comment-face)) + "Level 5." + :group 'outlines) + +(defface outline-6 + '((t :inherit font-lock-constant-face)) + "Level 6." + :group 'outlines) + +(defface outline-7 + '((t :inherit font-lock-type-face)) + "Level 7." + :group 'outlines) + +(defface outline-8 + '((t :inherit font-lock-string-face)) + "Level 8." + :group 'outlines) (defvar outline-font-lock-faces [outline-1 outline-2 outline-3 outline-4 @@ -422,55 +457,80 @@ If INVISIBLE-OK is non-nil, an invisible heading line is ok too." (save-excursion (newline-and-indent))) (run-hooks 'outline-insert-heading-hook))) -(defun outline-promote (&optional children) +(defun outline-invent-heading (head up) + (save-match-data + ;; Let's try to invent one by repeating or deleting the last char. + (let ((new-head (if up (substring head 0 -1) + (concat head (substring head -1))))) + (if (string-match (concat "\\`\\(?:" outline-regexp "\\)") + new-head) + ;; Why bother checking that it is indeed higher/lower level ? + new-head + ;; Didn't work, so ask what to do. + (read-string (format "%s heading for `%s': " + (if up "Parent" "Demoted") head) + head nil nil t))))) + +(defun outline-promote (&optional which) "Promote headings higher up the tree. -If prefix argument CHILDREN is given, promote also all the children. -If the region is active in `transient-mark-mode', promote all headings -in the region." +If transient-mark-mode is on, and mark is active, promote headings in +the region (from a Lisp program, pass `region' for WHICH). Otherwise: +without prefix argument, promote current heading and all headings in the +subtree (from a Lisp program, pass `subtree' for WHICH); with prefix +argument, promote just the current heading (from a Lisp program, pass +nil for WHICH, or do not pass any argument)." (interactive (list (if (and transient-mark-mode mark-active) 'region (outline-back-to-heading) (if current-prefix-arg nil 'subtree)))) (cond - ((eq children 'region) + ((eq which 'region) (outline-map-region 'outline-promote (region-beginning) (region-end))) - (children + (which (outline-map-region 'outline-promote (point) (save-excursion (outline-get-next-sibling) (point)))) (t (outline-back-to-heading t) - (let* ((head (match-string 0)) + (let* ((head (match-string-no-properties 0)) (level (save-match-data (funcall outline-level))) (up-head (or (outline-head-from-level (1- level) head) + ;; Use the parent heading, if it is really + ;; one level less. (save-excursion (save-match-data (outline-up-heading 1 t) - (match-string 0)))))) + (and (= (1- level) (funcall outline-level)) + (match-string-no-properties 0)))) + ;; Bummer!! There is no lower level heading. + (outline-invent-heading head 'up)))) (unless (rassoc level outline-heading-alist) (push (cons head level) outline-heading-alist)) (replace-match up-head nil t))))) -(defun outline-demote (&optional children) +(defun outline-demote (&optional which) "Demote headings lower down the tree. -If prefix argument CHILDREN is given, demote also all the children. -If the region is active in `transient-mark-mode', demote all headings -in the region." +If transient-mark-mode is on, and mark is active, demote headings in +the region (from a Lisp program, pass `region' for WHICH). Otherwise: +without prefix argument, demote current heading and all headings in the +subtree (from a Lisp program, pass `subtree' for WHICH); with prefix +argument, demote just the current heading (from a Lisp program, pass +nil for WHICH, or do not pass any argument)." (interactive (list (if (and transient-mark-mode mark-active) 'region (outline-back-to-heading) (if current-prefix-arg nil 'subtree)))) (cond - ((eq children 'region) + ((eq which 'region) (outline-map-region 'outline-demote (region-beginning) (region-end))) - (children + (which (outline-map-region 'outline-demote (point) (save-excursion (outline-get-next-sibling) (point)))) (t - (let* ((head (match-string 0)) + (let* ((head (match-string-no-properties 0)) (level (save-match-data (funcall outline-level))) (down-head (or (outline-head-from-level (1+ level) head) @@ -485,21 +545,13 @@ in the region." (<= (funcall outline-level) level)))) (unless (eobp) (looking-at outline-regexp) - (match-string 0)))) - (save-match-data - ;; Bummer!! There is no lower heading in the buffer. - ;; Let's try to invent one by repeating the first char. - (let ((new-head (concat (substring head 0 1) head))) - (if (string-match (concat "\\`\\(?:" outline-regexp "\\)") - new-head) - ;; Why bother checking that it is indeed lower level ? - new-head - ;; Didn't work: keep it as is so it's still a heading. - head)))))) - - (unless (rassoc level outline-heading-alist) - (push (cons head level) outline-heading-alist)) - (replace-match down-head nil t))))) + (match-string-no-properties 0)))) + ;; Bummer!! There is no higher-level heading in the buffer. + (outline-invent-heading head nil)))) + + (unless (rassoc level outline-heading-alist) + (push (cons head level) outline-heading-alist)) + (replace-match down-head nil t))))) (defun outline-head-from-level (level head &optional alist) "Get new heading with level LEVEL from ALIST. @@ -562,12 +614,11 @@ the match data is set appropriately." (defun outline-move-subtree-down (&optional arg) "Move the currrent subtree down past ARG headlines of the same level." (interactive "p") - (let ((re (concat "^\\(?:" outline-regexp "\\)")) - (movfunc (if (> arg 0) 'outline-get-next-sibling + (let ((movfunc (if (> arg 0) 'outline-get-next-sibling 'outline-get-last-sibling)) (ins-point (make-marker)) (cnt (abs arg)) - beg end txt folded) + beg end folded) ;; Select the tree (outline-back-to-heading) (setq beg (point)) @@ -607,19 +658,24 @@ A heading line is one that starts with a `*' (or that (if (< arg 0) (beginning-of-line) (end-of-line)) - (while (and (not (bobp)) (< arg 0)) - (while (and (not (bobp)) - (re-search-backward (concat "^\\(?:" outline-regexp "\\)") - nil 'move) - (outline-invisible-p))) - (setq arg (1+ arg))) - (while (and (not (eobp)) (> arg 0)) - (while (and (not (eobp)) - (re-search-forward (concat "^\\(?:" outline-regexp "\\)") - nil 'move) - (outline-invisible-p (match-beginning 0)))) - (setq arg (1- arg))) - (beginning-of-line)) + (let (found-heading-p) + (while (and (not (bobp)) (< arg 0)) + (while (and (not (bobp)) + (setq found-heading-p + (re-search-backward + (concat "^\\(?:" outline-regexp "\\)") + nil 'move)) + (outline-invisible-p))) + (setq arg (1+ arg))) + (while (and (not (eobp)) (> arg 0)) + (while (and (not (eobp)) + (setq found-heading-p + (re-search-forward + (concat "^\\(?:" outline-regexp "\\)") + nil 'move)) + (outline-invisible-p (match-beginning 0)))) + (setq arg (1- arg))) + (if found-heading-p (beginning-of-line)))) (defun outline-previous-visible-heading (arg) "Move to the previous heading line. @@ -641,19 +697,29 @@ This puts point at the start of the current subtree, and mark at the end." (outline-previous-visible-heading 1)) (setq beg (point)) (outline-end-of-subtree) - (push-mark (point)) + (push-mark (point) nil t) (goto-char beg))) +(defvar outline-isearch-open-invisible-function nil + "Function called if `isearch' finishes in an invisible overlay. +The function is called with the overlay as its only argument. +If nil, `show-entry' is called to reveal the invisible text.") + (put 'outline 'reveal-toggle-invisible 'outline-reveal-toggle-invisible) (defun outline-flag-region (from to flag) "Hide or show lines from FROM to TO, according to FLAG. If FLAG is nil then text is shown, while if FLAG is t the text is hidden." (remove-overlays from to 'invisible 'outline) (when flag - (let ((o (make-overlay from to))) + ;; We use `front-advance' here because the invisible text begins at the + ;; very end of the heading, before the newline, so text inserted at FROM + ;; belongs to the heading rather than to the entry. + (let ((o (make-overlay from to nil 'front-advance))) (overlay-put o 'invisible 'outline) - (overlay-put o 'isearch-open-invisible 'outline-isearch-open-invisible))) + (overlay-put o 'isearch-open-invisible + (or outline-isearch-open-invisible-function + 'outline-isearch-open-invisible)))) ;; Seems only used by lazy-lock. I.e. obsolete. (run-hooks 'outline-view-change-hook)) @@ -708,8 +774,8 @@ If FLAG is nil then text is shown, while if FLAG is t the text is hidden." (defun hide-entry () "Hide the body directly following this heading." (interactive) - (outline-back-to-heading) (save-excursion + (outline-back-to-heading) (outline-end-of-heading) (outline-flag-region (point) (progn (outline-next-preface) (point)) t))) @@ -759,11 +825,12 @@ Show the heading too, if it is currently invisible." (outline-flag-subtree t)) (defun hide-leaves () - "Hide all body after this heading at deeper levels." + "Hide the body after this heading and at deeper levels." (interactive) - (outline-back-to-heading) (save-excursion - (outline-end-of-heading) + (outline-back-to-heading) +;; Turned off to fix bug reported by Otto Maddox on 22 Nov 2005. +;; (outline-end-of-heading) (hide-region-body (point) (progn (outline-end-of-subtree) (point))))) (defun show-subtree () @@ -783,22 +850,34 @@ Show the heading too, if it is currently invisible." (defun hide-sublevels (levels) "Hide everything but the top LEVELS levels of headers, in whole buffer." - (interactive "p") + (interactive (list + (cond + (current-prefix-arg (prefix-numeric-value current-prefix-arg)) + ((save-excursion (beginning-of-line) + (looking-at outline-regexp)) + (funcall outline-level)) + (t 1)))) (if (< levels 1) (error "Must keep at least one level of headers")) - (let (outline-view-change-hook) - (save-excursion - (goto-char (point-min)) - ;; Skip the prelude, if any. - (unless (outline-on-heading-p t) (outline-next-heading)) + (save-excursion + (let* (outline-view-change-hook + (beg (progn + (goto-char (point-min)) + ;; Skip the prelude, if any. + (unless (outline-on-heading-p t) (outline-next-heading)) + (point))) + (end (progn + (goto-char (point-max)) + ;; Keep empty last line, if available. + (if (bolp) (1- (point)) (point))))) ;; First hide everything. - (outline-flag-region (point) (point-max) t) + (outline-flag-region beg end t) ;; Then unhide the top level headers. (outline-map-region (lambda () (if (<= (funcall outline-level) levels) (outline-show-heading))) - (point) (point-max)))) + beg end))) (run-hooks 'outline-view-change-hook)) (defun hide-other () @@ -819,11 +898,12 @@ Show the heading too, if it is currently invisible." (defun outline-toggle-children () "Show or hide the current subtree depending on its current state." (interactive) - (outline-back-to-heading) - (if (not (outline-invisible-p (line-end-position))) - (hide-subtree) - (show-children) - (show-entry))) + (save-excursion + (outline-back-to-heading) + (if (not (outline-invisible-p (line-end-position))) + (hide-subtree) + (show-children) + (show-entry)))) (defun outline-flag-subtree (flag) (save-excursion @@ -835,14 +915,14 @@ Show the heading too, if it is currently invisible." (defun outline-end-of-subtree () (outline-back-to-heading) - (let ((opoint (point)) - (first t) + (let ((first t) (level (funcall outline-level))) (while (and (not (eobp)) (or first (> (funcall outline-level) level))) (setq first nil) (outline-next-heading)) - (if (bolp) + (if (and (bolp) (not (eolp))) + ;; We stopped at a nonempty line (the next heading). (progn ;; Go to end of line before heading (forward-char -1) @@ -923,7 +1003,8 @@ Stop at the first and last subheadings of a superior heading." (error "No following same-level heading")))))) (defun outline-get-next-sibling () - "Move to next heading of the same level, and return point or nil if none." + "Move to next heading of the same level, and return point. +If there is no such heading, return nil." (let ((level (funcall outline-level))) (outline-next-visible-heading 1) (while (and (not (eobp)) (> (funcall outline-level) level)) @@ -949,15 +1030,18 @@ Stop at the first and last subheadings of a superior heading." (error "No previous same-level heading")))))) (defun outline-get-last-sibling () - "Move to previous heading of the same level, and return point or nil if none." - (let ((level (funcall outline-level))) + "Move to previous heading of the same level, and return point. +If there is no such heading, return nil." + (let ((opoint (point)) + (level (funcall outline-level))) (outline-previous-visible-heading 1) - (while (and (> (funcall outline-level) level) - (not (bobp))) - (outline-previous-visible-heading 1)) - (if (< (funcall outline-level) level) - nil - (point)))) + (when (and (/= (point) opoint) (outline-on-heading-p)) + (while (and (> (funcall outline-level) level) + (not (bobp))) + (outline-previous-visible-heading 1)) + (if (< (funcall outline-level) level) + nil + (point))))) (defun outline-headers-as-kill (beg end) "Save the visible outline headers in region at the start of the kill ring. @@ -996,5 +1080,5 @@ convenient way to make a table of contents of the buffer." (provide 'outline) (provide 'noutline) -;;; arch-tag: 1724410e-7d4d-4f46-b801-49e18171e874 +;; arch-tag: 1724410e-7d4d-4f46-b801-49e18171e874 ;;; outline.el ends here