/[emacs]/emacs/lisp/textmodes/outline.el
ViewVC logotype

Diff of /emacs/lisp/textmodes/outline.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.53 by monnier, Mon May 20 18:32:07 2002 UTC revision 1.53.2.1 by miles, Fri Apr 4 06:20:37 2003 UTC
# Line 80  in the file it applies to." Line 80  in the file it applies to."
80      (define-key map "\C-k" 'show-branches)      (define-key map "\C-k" 'show-branches)
81      (define-key map "\C-q" 'hide-sublevels)      (define-key map "\C-q" 'hide-sublevels)
82      (define-key map "\C-o" 'hide-other)      (define-key map "\C-o" 'hide-other)
83      (define-key map "\C-^" 'outline-promote)      (define-key map "\C-^" 'outline-move-subtree-up)
84      (define-key map "\C-v" 'outline-demote)      (define-key map "\C-v" 'outline-move-subtree-down)
85      ;; Where to bind toggle and insert-heading ?      (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))      map))
90    
91  (defvar outline-mode-menu-bar-map  (defvar outline-mode-menu-bar-map
# Line 108  in the file it applies to." Line 111  in the file it applies to."
111      (define-key map [headings]      (define-key map [headings]
112        (cons "Headings" (make-sparse-keymap "Headings")))        (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]      (define-key map [headings copy]
123        '(menu-item "Copy to kill ring" outline-headers-as-kill        '(menu-item "Copy to kill ring" outline-headers-as-kill
124          :enable mark-active))          :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]      (define-key map [headings outline-backward-same-level]
128        '("Previous Same Level" . outline-backward-same-level))        '("Previous Same Level" . outline-backward-same-level))
129      (define-key map [headings outline-forward-same-level]      (define-key map [headings outline-forward-same-level]
# Line 150  in the file it applies to." Line 163  in the file it applies to."
163  (defvar outline-font-lock-keywords  (defvar outline-font-lock-keywords
164    '(;;    '(;;
165      ;; Highlight headings according to the level.      ;; Highlight headings according to the level.
166      (eval . (list (concat "^" outline-regexp ".+")      (eval . (list (concat "^\\(?:" outline-regexp "\\).+")
167                    0 '(or (cdr (assq (outline-font-lock-level)                    0 '(outline-font-lock-face) nil t)))
                                     ;; FIXME: this is silly!  
                                     '((1 . font-lock-function-name-face)  
                                       (2 . font-lock-variable-name-face)  
                                       (3 . font-lock-keyword-face)  
                                       (4 . font-lock-builtin-face)  
                                       (5 . font-lock-comment-face)  
                                       (6 . font-lock-constant-face)  
                                       (7 . font-lock-type-face)  
                                       (8 . font-lock-string-face))))  
                          font-lock-warning-face)  
                   nil t)))  
168    "Additional expressions to highlight in Outline mode.")    "Additional expressions to highlight in Outline mode.")
169    
170  (defun outline-font-lock-level ()  (defface outline-1 '((t :inherit font-lock-function-name-face)) "Level 1.")
171    (let ((count 1))  (defface outline-2 '((t :inherit font-lock-variable-name-face)) "Level 2.")
172      (save-excursion  (defface outline-3 '((t :inherit font-lock-keyword-face)) "Level 3.")
173        (outline-back-to-heading t)  (defface outline-4 '((t :inherit font-lock-builtin-face)) "Level 4.")
174        (while (and (not (bobp))  (defface outline-5 '((t :inherit font-lock-comment-face)) "Level 5.")
175                    (not (eq (funcall outline-level) 1)))  (defface outline-6 '((t :inherit font-lock-constant-face)) "Level 6.")
176          (outline-up-heading 1 t)  (defface outline-7 '((t :inherit font-lock-type-face)) "Level 7.")
177          (setq count (1+ count)))  (defface outline-8 '((t :inherit font-lock-string-face)) "Level 8.")
178        count)))  
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  (defvar outline-view-change-hook nil
214    "Normal hook to be run after outline visibility changes.")    "Normal hook to be run after outline visibility changes.")
# Line 198  Commands:\\<outline-mode-map> Line 233  Commands:\\<outline-mode-map>
233    
234  \\[hide-body]   make all text invisible (not headings).  \\[hide-body]   make all text invisible (not headings).
235  \\[show-all]    make everything in buffer visible.  \\[show-all]    make everything in buffer visible.
236    \\[hide-sublevels]  make only the first N levels of headers visible.
237    
238  The remaining commands are used when point is on a heading line.  The remaining commands are used when point is on a heading line.
239  They apply to some of the body or subheadings of that heading.  They apply to some of the body or subheadings of that heading.
# Line 223  Turning on outline mode calls the value Line 259  Turning on outline mode calls the value
259    ;; Cause use of ellipses for invisible text.    ;; Cause use of ellipses for invisible text.
260    (add-to-invisibility-spec '(outline . t))    (add-to-invisibility-spec '(outline . t))
261    (set (make-local-variable 'paragraph-start)    (set (make-local-variable 'paragraph-start)
262         (concat paragraph-start "\\|\\(" outline-regexp "\\)"))         (concat paragraph-start "\\|\\(?:" outline-regexp "\\)"))
263    ;; Inhibit auto-filling of header lines.    ;; Inhibit auto-filling of header lines.
264    (set (make-local-variable 'auto-fill-inhibit-regexp) outline-regexp)    (set (make-local-variable 'auto-fill-inhibit-regexp) outline-regexp)
265    (set (make-local-variable 'paragraph-separate)    (set (make-local-variable 'paragraph-separate)
266         (concat paragraph-separate "\\|\\(" outline-regexp "\\)"))         (concat paragraph-separate "\\|\\(?:" outline-regexp "\\)"))
267    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
268         '(outline-font-lock-keywords t nil nil backward-paragraph))         '(outline-font-lock-keywords t nil nil backward-paragraph))
269    (setq imenu-generic-expression    (setq imenu-generic-expression
# Line 248  With arg, turn Outline minor mode on if Line 284  With arg, turn Outline minor mode on if
284  See the command `outline-mode' for more information on this mode."  See the command `outline-mode' for more information on this mode."
285    nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)    nil " Outl" (list (cons [menu-bar] outline-minor-mode-menu-bar-map)
286                      (cons outline-minor-mode-prefix outline-mode-prefix-map))                      (cons outline-minor-mode-prefix outline-mode-prefix-map))
287      :group 'outlines
288    (if outline-minor-mode    (if outline-minor-mode
289        (progn        (progn
290          ;; Turn off this mode if we change major modes.          ;; Turn off this mode if we change major modes.
# Line 263  See the command `outline-mode' for more Line 300  See the command `outline-mode' for more
300      ;; When turning off outline mode, get rid of any outline hiding.      ;; When turning off outline mode, get rid of any outline hiding.
301      (show-all)))      (show-all)))
302    
303  (defcustom outline-level 'outline-level  (defvar outline-level 'outline-level
304    "*Function of no args to compute a header's nesting level in an outline.    "*Function of no args to compute a header's nesting level in an outline.
305  It can assume point is at the beginning of a header line."  It can assume point is at the beginning of a header line and that the match
306    :type 'function  data reflects the `outline-regexp'.")
   :group 'outlines)  
307    
308  (defvar outline-heading-alist ()  (defvar outline-heading-alist ()
309    "Alist associating a heading for every possible level.    "Alist associating a heading for every possible level.
310  Each entry is of the form (HEADING . LEVEL).  Each entry is of the form (HEADING . LEVEL).
311  This alist is used both to find the heading corresponding to  This alist is used two ways: to find the heading corresponding to
312  a given level and to find the level of a given heading.")  a given level and to find the level of a given heading.
313    If a mode or document needs several sets of outline headings (for example
314    numbered and unnumbered sections), list them set by set and sorted by level
315    within each set.  For example in texinfo mode:
316    
317         (setq outline-heading-alist
318          '((\"@chapter\" . 2) (\"@section\" . 3) (\"@subsection\" . 4)
319               (\"@subsubsection\" . 5)
320            (\"@unnumbered\" . 2) (\"@unnumberedsec\" . 3)
321               (\"@unnumberedsubsec\" . 4)  (\"@unnumberedsubsubsec\" . 5)
322            (\"@appendix\" . 2) (\"@appendixsec\" . 3)...
323               (\"@appendixsubsec\" . 4) (\"@appendixsubsubsec\" . 5) ..))
324    
325    Instead of sorting the entries in each set, you can also separate the
326    sets with nil.")
327  (make-variable-buffer-local 'outline-heading-alist)  (make-variable-buffer-local 'outline-heading-alist)
328    
329  ;; This used to count columns rather than characters, but that made ^L  ;; This used to count columns rather than characters, but that made ^L
# Line 286  a given level and to find the level of a Line 336  a given level and to find the level of a
336  Point must be at the beginning of a header line.  Point must be at the beginning of a header line.
337  This is actually either the level specified in `outline-heading-alist'  This is actually either the level specified in `outline-heading-alist'
338  or else the number of characters matched by `outline-regexp'."  or else the number of characters matched by `outline-regexp'."
339    (save-excursion    (or (cdr (assoc (match-string 0) outline-heading-alist))
340      (if (not (looking-at outline-regexp))        (- (match-end 0) (match-beginning 0))))
         ;; This should never happen  
         1000  
       (or (cdr (assoc (match-string 0) outline-heading-alist))  
           (- (match-end 0) (match-beginning 0))))))  
341    
342  (defun outline-next-preface ()  (defun outline-next-preface ()
343    "Skip forward to just before the next heading line.    "Skip forward to just before the next heading line.
344  If there's no following heading line, stop before the newline  If there's no following heading line, stop before the newline
345  at the end of the buffer."  at the end of the buffer."
346    (if (re-search-forward (concat "\n\\(" outline-regexp "\\)")    (if (re-search-forward (concat "\n\\(?:" outline-regexp "\\)")
347                           nil 'move)                           nil 'move)
348        (goto-char (match-beginning 0)))        (goto-char (match-beginning 0)))
349    (if (and (bolp) (not (bobp)))    (if (and (bolp) (not (bobp)))
# Line 306  at the end of the buffer." Line 352  at the end of the buffer."
352  (defun outline-next-heading ()  (defun outline-next-heading ()
353    "Move to the next (possibly invisible) heading line."    "Move to the next (possibly invisible) heading line."
354    (interactive)    (interactive)
355    (if (re-search-forward (concat "\n\\(" outline-regexp "\\)")    ;; Make sure we don't match the heading we're at.
356      (if (and (bolp) (not (eobp))) (forward-char 1))
357      (if (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
358                           nil 'move)                           nil 'move)
359        (goto-char (1+ (match-beginning 0)))))        (goto-char (match-beginning 0))))
360    
361  (defun outline-previous-heading ()  (defun outline-previous-heading ()
362    "Move to the previous (possibly invisible) heading line."    "Move to the previous (possibly invisible) heading line."
363    (interactive)    (interactive)
364    (re-search-backward (concat "^\\(" outline-regexp "\\)")    (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
365                        nil 'move))                        nil 'move))
366    
367  (defsubst outline-invisible-p ()  (defsubst outline-invisible-p (&optional pos)
368    "Non-nil if the character after point is invisible."    "Non-nil if the character after point is invisible."
369    (get-char-property (point) 'invisible))    (get-char-property (or pos (point)) 'invisible))
370    
371  (defun outline-visible ()  (defun outline-visible ()
   "Obsolete.  Use `outline-invisible-p'."  
372    (not (outline-invisible-p)))    (not (outline-invisible-p)))
373    (make-obsolete 'outline-visible 'outline-invisible-p)
374    
375  (defun outline-back-to-heading (&optional invisible-ok)  (defun outline-back-to-heading (&optional invisible-ok)
376    "Move to previous heading line, or beg of this line if it's a heading.    "Move to previous heading line, or beg of this line if it's a heading.
# Line 331  Only visible heading lines are considere Line 380  Only visible heading lines are considere
380        (let (found)        (let (found)
381          (save-excursion          (save-excursion
382            (while (not found)            (while (not found)
383              (or (re-search-backward (concat "^\\(" outline-regexp "\\)")              (or (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
384                                      nil t)                                      nil t)
385                  (error "before first heading"))                  (error "before first heading"))
386              (setq found (and (or invisible-ok (not (outline-invisible-p)))              (setq found (and (or invisible-ok (not (outline-invisible-p)))
# Line 367  If INVISIBLE-OK is non-nil, an invisible Line 416  If INVISIBLE-OK is non-nil, an invisible
416      (run-hooks 'outline-insert-heading-hook)))      (run-hooks 'outline-insert-heading-hook)))
417    
418  (defun outline-promote (&optional children)  (defun outline-promote (&optional children)
419    "Promote the current heading higher up the tree.    "Promote headings higher up the tree.
420  If prefix argument CHILDREN is given, promote also all the children."  If prefix argument CHILDREN is given, promote also all the children.
421    (interactive "P")  If the region is active in `transient-mark-mode', promote all headings
422    (outline-back-to-heading)  in the region."
423    (let* ((head (match-string 0))    (interactive
424           (level (save-match-data (funcall outline-level)))     (list (if (and transient-mark-mode mark-active) 'region
425           (up-head (or (car (rassoc (1- level) outline-heading-alist))             (outline-back-to-heading)
426                        (save-excursion             (if current-prefix-arg nil 'subtree))))
427                          (save-match-data    (cond
428                            (outline-up-heading 1 t)     ((eq children 'region)
429                            (match-string 0))))))      (outline-map-region 'outline-promote (region-beginning) (region-end)))
430           (children
431      (unless (rassoc level outline-heading-alist)      (outline-map-region 'outline-promote
432        (push (cons head level) outline-heading-alist))                          (point)
433                            (save-excursion (outline-get-next-sibling) (point))))
434      (replace-match up-head nil t)     (t
435      (when children      (outline-back-to-heading t)
436        (outline-map-tree 'outline-promote level))))      (let* ((head (match-string 0))
437               (level (save-match-data (funcall outline-level)))
438               (up-head (or (outline-head-from-level (1- level) head)
439                            (save-excursion
440                              (save-match-data
441                                (outline-up-heading 1 t)
442                                (match-string 0))))))
443          
444          (unless (rassoc level outline-heading-alist)
445            (push (cons head level) outline-heading-alist))
446          
447          (replace-match up-head nil t)))))
448    
449  (defun outline-demote (&optional children)  (defun outline-demote (&optional children)
450    "Demote the current heading lower down the tree.    "Demote headings lower down the tree.
451  If prefix argument CHILDREN is given, demote also all the children."  If prefix argument CHILDREN is given, demote also all the children.
452    (interactive "P")  If the region is active in `transient-mark-mode', demote all headings
453    (outline-back-to-heading)  in the region."
454    (let* ((head (match-string 0))    (interactive
455           (level (save-match-data (funcall outline-level)))     (list (if (and transient-mark-mode mark-active) 'region
456           (down-head             (outline-back-to-heading)
457            (or (car (rassoc (1+ level) outline-heading-alist))             (if current-prefix-arg nil 'subtree))))
458                (save-excursion    (cond
459       ((eq children 'region)
460        (outline-map-region 'outline-demote (region-beginning) (region-end)))
461       (children
462        (outline-map-region 'outline-demote
463                            (point)
464                            (save-excursion (outline-get-next-sibling) (point))))
465       (t
466        (let* ((head (match-string 0))
467               (level (save-match-data (funcall outline-level)))
468               (down-head
469                (or (outline-head-from-level (1+ level) head)
470                    (save-excursion
471                      (save-match-data
472                        (while (and (progn (outline-next-heading) (not (eobp)))
473                                    (<= (funcall outline-level) level)))
474                        (when (eobp)
475                          ;; Try again from the beginning of the buffer.
476                          (goto-char (point-min))
477                          (while (and (progn (outline-next-heading) (not (eobp)))
478                                      (<= (funcall outline-level) level))))
479                        (unless (eobp)
480                          (looking-at outline-regexp)
481                          (match-string 0))))
482                  (save-match-data                  (save-match-data
483                    (while (and (not (eobp))                    ;; Bummer!! There is no lower heading in the buffer.
484                                (progn                    ;; Let's try to invent one by repeating the first char.
485                                  (outline-next-heading)                    (let ((new-head (concat (substring head 0 1) head)))
486                                  (<= (funcall outline-level) level))))                      (if (string-match (concat "\\`" outline-regexp) new-head)
487                    (when (eobp)                          ;; Why bother checking that it is indeed lower level ?
488                      ;; Try again from the beginning of the buffer.                          new-head
489                      (goto-char (point-min))                        ;; Didn't work: keep it as is so it's still a heading.
490                      (while (and (not (eobp))                        head))))))
                                 (progn  
                                   (outline-next-heading)  
                                   (<= (funcall outline-level) level)))))  
                   (unless (eobp) (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 of lower level ?  
                       new-head  
                     ;; Didn't work: keep it as is so it's still a heading.  
                     head))))))  
491    
492      (unless (rassoc level outline-heading-alist)      (unless (rassoc level outline-heading-alist)
493        (push (cons head level) outline-heading-alist))        (push (cons head level) outline-heading-alist))
494            (replace-match down-head nil t)))))
     (replace-match down-head nil t)  
     (when children  
       (outline-map-tree 'outline-demote level))))  
495    
496  (defun outline-map-tree (fun level)  (defun outline-head-from-level (level head &optional alist)
497    "Call FUN for every heading underneath the current one."    "Get new heading with level LEVEL from ALIST.
498    If there are no such entries, return nil.
499    ALIST defaults to `outline-heading-alist'.
500    Similar to (car (rassoc LEVEL ALIST)).
501    If there are several different entries with same new level, choose
502    the one with the smallest distance to the assocation of HEAD in the alist.
503    This makes it possible for promotion to work in modes with several
504    independent sets of headings (numbered, unnumbered, appendix...)"
505      (unless alist (setq alist outline-heading-alist))
506      (let ((l (rassoc level alist))
507            ll h hl l2 l2l)
508        (cond
509         ((null l) nil)
510         ;; If there's no HEAD after L, any other entry for LEVEL after L
511         ;; can't be much better than L.
512         ((null (setq h (assoc head (setq ll (memq l alist))))) (car l))
513         ;; If there's no other entry for LEVEL, just keep L.
514         ((null (setq l2 (rassoc level (cdr ll)))) (car l))
515         ;; Now we have L, L2, and H: see if L2 seems better than L.
516         ;; If H is after L2, L2 is better.
517         ((memq h (setq l2l (memq l2 (cdr ll))))
518          (outline-head-from-level level head l2l))
519         ;; Now we have H between L and L2.
520         ;; If there's a separator between L and H, prefer L2.
521         ((memq h (memq nil ll))
522          (outline-head-from-level level head l2l))
523         ;; If there's a separator between L2 and H, prefer L.
524         ((memq l2 (memq nil (setq hl (memq h ll)))) (car l))
525         ;; No separator between L and L2, check the distance.
526         ((< (* 2 (length hl)) (+ (length ll) (length l2l)))
527          (outline-head-from-level level head l2l))
528         ;; If all else fails, just keep L.
529         (t (car l)))))
530    
531    (defun outline-map-region (fun beg end)
532      "Call FUN for every heading between BEG and END.
533    When FUN is called, point is at the beginning of the heading and
534    the match data is set appropriately."
535    (save-excursion    (save-excursion
536      (while (and (progn      (setq end (copy-marker end))
537                    (outline-next-heading)      (goto-char beg)
538                    (> (funcall outline-level) level))      (when (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t)
539                  (not (eobp)))        (goto-char (match-beginning 0))
540        (funcall fun))))        (funcall fun)
541          (while (and (progn
542                        (outline-next-heading)
543                        (< (point) end))
544                      (not (eobp)))
545            (funcall fun)))))
546    
547    ;; Vertical tree motion
548    
549    (defun outline-move-subtree-up (&optional arg)
550      "Move the currrent subtree up past ARG headlines of the same level."
551      (interactive "p")
552      (outline-move-subtree-down (- arg)))
553    
554    (defun outline-move-subtree-down (&optional arg)
555      "Move the currrent subtree down past ARG headlines of the same level."
556      (interactive "p")
557      (let ((re (concat "^" outline-regexp))
558            (movfunc (if (> arg 0) 'outline-get-next-sibling
559                       'outline-get-last-sibling))
560            (ins-point (make-marker))
561            (cnt (abs arg))
562            beg end txt folded)
563        ;; Select the tree
564        (outline-back-to-heading)
565        (setq beg (point))
566        (save-match-data
567          (save-excursion (outline-end-of-heading)
568                          (setq folded (outline-invisible-p)))
569          (outline-end-of-subtree))
570        (if (= (char-after) ?\n) (forward-char 1))
571        (setq end (point))
572        ;; Find insertion point, with error handling
573        (goto-char beg)
574        (while (> cnt 0)
575          (or (funcall movfunc)
576              (progn (goto-char beg)
577                     (error "Cannot move past superior level")))
578          (setq cnt (1- cnt)))
579        (if (> arg 0)
580            ;; Moving forward - still need to move over subtree
581            (progn (outline-end-of-subtree)
582                   (if (= (char-after) ?\n) (forward-char 1))))
583        (move-marker ins-point (point))
584        (insert (delete-and-extract-region beg end))
585        (goto-char ins-point)
586        (if folded (hide-subtree))
587        (move-marker ins-point nil)))
588    
589  (defun outline-end-of-heading ()  (defun outline-end-of-heading ()
590    (if (re-search-forward outline-heading-end-regexp nil 'move)    (if (re-search-forward outline-heading-end-regexp nil 'move)
# Line 450  A heading line is one that starts with a Line 601  A heading line is one that starts with a
601      (end-of-line))      (end-of-line))
602    (while (and (not (bobp)) (< arg 0))    (while (and (not (bobp)) (< arg 0))
603      (while (and (not (bobp))      (while (and (not (bobp))
604                  (re-search-backward (concat "^\\(" outline-regexp "\\)")                  (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
605                                      nil 'move)                                      nil 'move)
606                  (outline-invisible-p)))                  (outline-invisible-p)))
607      (setq arg (1+ arg)))      (setq arg (1+ arg)))
608    (while (and (not (eobp)) (> arg 0))    (while (and (not (eobp)) (> arg 0))
609      (while (and (not (eobp))      (while (and (not (eobp))
610                  (re-search-forward (concat "^\\(" outline-regexp "\\)")                  (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
611                                     nil 'move)                                     nil 'move)
612                  (outline-invisible-p)))                  (outline-invisible-p (match-beginning 0))))
613      (setq arg (1- arg)))      (setq arg (1- arg)))
614    (beginning-of-line))    (beginning-of-line))
615    
# Line 611  Show the heading too, if it is currently Line 762  Show the heading too, if it is currently
762    (interactive)    (interactive)
763    (outline-flag-subtree nil))    (outline-flag-subtree nil))
764    
765    (defun outline-show-heading ()
766      "Show the current heading and move to its end."
767      (outline-flag-region (- (point)
768                              (if (bobp) 0
769                                (if (eq (char-before (1- (point))) ?\n)
770                                    2 1)))
771                           (progn (outline-end-of-heading) (point))
772                           nil))
773    
774  (defun hide-sublevels (levels)  (defun hide-sublevels (levels)
775    "Hide everything but the top LEVELS levels of headers, in whole buffer."    "Hide everything but the top LEVELS levels of headers, in whole buffer."
776    (interactive "p")    (interactive "p")
777    (if (< levels 1)    (if (< levels 1)
778        (error "Must keep at least one level of headers"))        (error "Must keep at least one level of headers"))
   (setq levels (1- levels))  
779    (let (outline-view-change-hook)    (let (outline-view-change-hook)
780      (save-excursion      (save-excursion
781        (goto-char (point-min))        (goto-char (point-min))
782        ;; Keep advancing to the next top-level heading.        ;; Skip the prelude, if any.
783        (while (or (and (bobp) (outline-on-heading-p))        (unless (outline-on-heading-p t) (outline-next-heading))
784                   (outline-next-heading))        ;; First hide everything.
785          (let ((end (save-excursion (outline-end-of-subtree) (point))))        (outline-flag-region (point) (point-max) t)
786            ;; Hide everything under that.        ;; Then unhide the top level headers.
787            (outline-end-of-heading)        (outline-map-region
788            (outline-flag-region (point) end t)         (lambda ()
789            ;; Show the first LEVELS levels under that.           (if (<= (funcall outline-level) levels)
790            (if (> levels 0)               (outline-show-heading)))
791                (show-children levels))         (point) (point-max))))
           ;; Move to the next, since we already found it.  
           (goto-char end)))))  
792    (run-hooks 'outline-view-change-hook))    (run-hooks 'outline-view-change-hook))
793    
794  (defun hide-other ()  (defun hide-other ()
# Line 653  Show the heading too, if it is currently Line 810  Show the heading too, if it is currently
810    "Show or hide the current subtree depending on its current state."    "Show or hide the current subtree depending on its current state."
811    (interactive)    (interactive)
812    (outline-back-to-heading)    (outline-back-to-heading)
813    (if (save-excursion    (if (not (outline-invisible-p (line-end-position)))
         (end-of-line)  
         (not (outline-invisible-p)))  
814        (hide-subtree)        (hide-subtree)
815      (show-children)      (show-children)
816      (show-entry)))      (show-entry)))
# Line 706  Default is enough to cause the following Line 861  Default is enough to cause the following
861                  (max 1 (- (funcall outline-level) start-level)))))))                  (max 1 (- (funcall outline-level) start-level)))))))
862    (let (outline-view-change-hook)    (let (outline-view-change-hook)
863      (save-excursion      (save-excursion
864        (save-restriction        (outline-back-to-heading)
865          (outline-back-to-heading)        (setq level (+ level (funcall outline-level)))
866          (setq level (+ level (funcall outline-level)))        (outline-map-region
867          (narrow-to-region (point)         (lambda ()
868                            (progn (outline-end-of-subtree)           (if (<= (funcall outline-level) level)
869                                   (if (eobp) (point-max) (1+ (point)))))               (outline-show-heading)))
870          (goto-char (point-min))         (point)
871          (while (and (not (eobp))         (progn (outline-end-of-subtree)
872                      (progn                (if (eobp) (point-max) (1+ (point)))))))
                       (outline-next-heading)  
                       (not (eobp))))  
           (if (<= (funcall outline-level) level)  
               (save-excursion  
                 (outline-flag-region (save-excursion  
                                        (forward-char -1)  
                                        (if (bolp)  
                                            (forward-char -1))  
                                        (point))  
                                      (progn (outline-end-of-heading) (point))  
                                      nil)))))))  
873    (run-hooks 'outline-view-change-hook))    (run-hooks 'outline-view-change-hook))
874    
875    
# Line 736  With argument, move up ARG levels. Line 880  With argument, move up ARG levels.
880  If INVISIBLE-OK is non-nil, also consider invisible lines."  If INVISIBLE-OK is non-nil, also consider invisible lines."
881    (interactive "p")    (interactive "p")
882    (outline-back-to-heading invisible-ok)    (outline-back-to-heading invisible-ok)
883    (if (eq (funcall outline-level) 1)    (let ((start-level (funcall outline-level)))
884        (error "Already at top level of the outline"))      (if (eq start-level 1)
885    (while (and (> (funcall outline-level) 1)          (error "Already at top level of the outline"))
886                (> arg 0)      (while (and (> start-level 1) (> arg 0) (not (bobp)))
887                (not (bobp)))        (let ((level start-level))
888      (let ((present-level (funcall outline-level)))          (while (not (or (< level start-level) (bobp)))
889        (while (and (not (< (funcall outline-level) present-level))            (if invisible-ok
890                    (not (bobp)))                (outline-previous-heading)
891          (if invisible-ok              (outline-previous-visible-heading 1))
892              (outline-previous-heading)            (setq level (funcall outline-level)))
893            (outline-previous-visible-heading 1)))          (setq start-level level))
894        (setq arg (- arg 1)))))        (setq arg (- arg 1))))
895      (looking-at outline-regexp))
896    
897  (defun outline-forward-same-level (arg)  (defun outline-forward-same-level (arg)
898    "Move forward to the ARG'th subheading at same level as this one.    "Move forward to the ARG'th subheading at same level as this one.
# Line 769  Stop at the first and last subheadings o Line 914  Stop at the first and last subheadings o
914    "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 or nil if none."
915    (let ((level (funcall outline-level)))    (let ((level (funcall outline-level)))
916      (outline-next-visible-heading 1)      (outline-next-visible-heading 1)
917      (while (and (> (funcall outline-level) level)      (while (and (not (eobp)) (> (funcall outline-level) level))
                 (not (eobp)))  
918        (outline-next-visible-heading 1))        (outline-next-visible-heading 1))
919      (if (< (funcall outline-level) level)      (if (or (eobp) (< (funcall outline-level) level))
920          nil          nil
921        (point))))        (point))))
922    

Legend:
Removed from v.1.53  
changed lines
  Added in v.1.53.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26