/[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.60 by lektu, Wed Feb 5 23:15:41 2003 UTC revision 1.61 by monnier, Thu Mar 13 18:15:07 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 139  in the file it applies to." Line 152  in the file it applies to."
152                                           (cons '(--- "---") (cdr x))))                                           (cons '(--- "---") (cdr x))))
153                                     outline-mode-menu-bar-map))))))                                     outline-mode-menu-bar-map))))))
154      map))      map))
155                  
156    
157  (defvar outline-mode-map  (defvar outline-mode-map
158    (let ((map (make-sparse-keymap)))    (let ((map (make-sparse-keymap)))
# Line 339  at the end of the buffer." Line 352  at the end of the buffer."
352    (re-search-backward (concat "^\\(?:" outline-regexp "\\)")    (re-search-backward (concat "^\\(?:" outline-regexp "\\)")
353                        nil 'move))                        nil 'move))
354    
355  (defsubst outline-invisible-p ()  (defsubst outline-invisible-p (&optional pos)
356    "Non-nil if the character after point is invisible."    "Non-nil if the character after point is invisible."
357    (get-char-property (point) 'invisible))    (get-char-property (or pos (point)) 'invisible))
358    
359  (defun outline-visible ()  (defun outline-visible ()
360    (not (outline-invisible-p)))    (not (outline-invisible-p)))
# Line 391  If INVISIBLE-OK is non-nil, an invisible Line 404  If INVISIBLE-OK is non-nil, an invisible
404      (run-hooks 'outline-insert-heading-hook)))      (run-hooks 'outline-insert-heading-hook)))
405    
406  (defun outline-promote (&optional children)  (defun outline-promote (&optional children)
407    "Promote the current heading higher up the tree.    "Promote headings higher up the tree.
408  If prefix argument CHILDREN is given, promote also all the children."  If prefix argument CHILDREN is given, promote also all the children.
409    (interactive "P")  If the region is active in `transient-mark-mode', promote all headings
410    (outline-back-to-heading)  in the region."
411    (let* ((head (match-string 0))    (interactive
412           (level (save-match-data (funcall outline-level)))     (list (if (and transient-mark-mode mark-active) 'region
413           (up-head (or (car (rassoc (1- level) outline-heading-alist))             (outline-back-to-heading)
414                        (save-excursion             (if current-prefix-arg nil 'subtree))))
415                          (save-match-data    (cond
416                            (outline-up-heading 1 t)     ((eq children 'region)
417                            (match-string 0))))))      (outline-map-region 'outline-promote (region-beginning) (region-end)))
418       (children
419      (unless (rassoc level outline-heading-alist)      (outline-map-region 'outline-promote
420        (push (cons head level) outline-heading-alist))                          (point)
421                            (save-excursion (outline-get-next-sibling) (point))))
422      (replace-match up-head nil t)     (t
423      (when children      (outline-back-to-heading t)
424        (outline-map-tree 'outline-promote level))))      (let* ((head (match-string 0))
425               (level (save-match-data (funcall outline-level)))
426               (up-head (or (car (rassoc (1- level) outline-heading-alist))
427                            (save-excursion
428                              (save-match-data
429                                (outline-up-heading 1 t)
430                                (match-string 0))))))
431          
432          (unless (rassoc level outline-heading-alist)
433            (push (cons head level) outline-heading-alist))
434          
435          (replace-match up-head nil t)))))
436    
437  (defun outline-demote (&optional children)  (defun outline-demote (&optional children)
438    "Demote the current heading lower down the tree.    "Demote headings lower down the tree.
439  If prefix argument CHILDREN is given, demote also all the children."  If prefix argument CHILDREN is given, demote also all the children.
440    (interactive "P")  If the region is active in `transient-mark-mode', demote all headings
441    (outline-back-to-heading)  in the region."
442    (let* ((head (match-string 0))    (interactive
443           (level (save-match-data (funcall outline-level)))     (list (if (and transient-mark-mode mark-active) 'region
444           (down-head             (outline-back-to-heading)
445            (or (car (rassoc (1+ level) outline-heading-alist))             (if current-prefix-arg nil 'subtree))))
446                (save-excursion    (cond
447                  (save-match-data     ((eq children 'region)
448                    (while (and (not (eobp))      (outline-map-region 'outline-demote (region-beginning) (region-end)))
449                                (progn     (children
450                                  (outline-next-heading)      (outline-map-region 'outline-demote
451                                  (<= (funcall outline-level) level))))                          (point)
452                    (when (eobp)                          (save-excursion (outline-get-next-sibling) (point))))
453                      ;; Try again from the beginning of the buffer.     (t
454                      (goto-char (point-min))      (let* ((head (match-string 0))
455               (level (save-match-data (funcall outline-level)))
456               (down-head
457                (or (car (rassoc (1+ level) outline-heading-alist))
458                    (save-excursion
459                      (save-match-data
460                      (while (and (not (eobp))                      (while (and (not (eobp))
461                                  (progn                                  (progn
462                                    (outline-next-heading)                                    (outline-next-heading)
463                                    (<= (funcall outline-level) level)))))                                    (<= (funcall outline-level) level))))
464                    (unless (eobp)                      (when (eobp)
465                      (looking-at outline-regexp)                        ;; Try again from the beginning of the buffer.
466                      (match-string 0))))                        (goto-char (point-min))
467                (save-match-data                        (while (and (not (eobp))
468                  ;; Bummer!! There is no lower heading in the buffer.                                    (progn
469                  ;; Let's try to invent one by repeating the first char.                                      (outline-next-heading)
470                  (let ((new-head (concat (substring head 0 1) head)))                                      (<= (funcall outline-level) level)))))
471                    (if (string-match (concat "\\`" outline-regexp) new-head)                      (unless (eobp)
472                        ;; Why bother checking that it is indeed of lower level ?                        (looking-at outline-regexp)
473                        new-head                        (match-string 0))))
474                      ;; Didn't work: keep it as is so it's still a heading.                  (save-match-data
475                      head))))))                    ;; Bummer!! There is no lower heading in the buffer.
476                      ;; Let's try to invent one by repeating the first char.
477                      (let ((new-head (concat (substring head 0 1) head)))
478                        (if (string-match (concat "\\`" outline-regexp) new-head)
479                            ;; Why bother checking that it is indeed lower level ?
480                            new-head
481                          ;; Didn't work: keep it as is so it's still a heading.
482                          head))))))
483    
484      (unless (rassoc level outline-heading-alist)      (unless (rassoc level outline-heading-alist)
485        (push (cons head level) outline-heading-alist))        (push (cons head level) outline-heading-alist))
486        (replace-match down-head nil t)))))
487    
488      (replace-match down-head nil t)  (defun outline-map-region (fun beg end)
489      (when children    "Call FUN for every heading between BEG and END.
490        (outline-map-tree 'outline-demote level))))  When FUN is called, point is at the beginning of the heading and
491    the match data is set appropriately."
 (defun outline-map-tree (fun level)  
   "Call FUN for every heading underneath the current one."  
492    (save-excursion    (save-excursion
493      (while (and (progn      (setq end (copy-marker end))
494                    (outline-next-heading)      (goto-char beg)
495                    (> (funcall outline-level) level))      (when (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t)
496                  (not (eobp)))        (goto-char (match-beginning 0))
497        (funcall fun))))        (funcall fun)
498          (while (and (progn
499                        (outline-next-heading)
500                        (< (point) end))
501                      (not (eobp)))
502            (funcall fun)))))
503    
504    ;; Vertical tree motion
505    
506    (defun outline-move-subtree-up (&optional arg)
507      "Move the currrent subtree up past ARG headlines of the same level."
508      (interactive "p")
509      (outline-move-subtree-down (- arg)))
510    
511    (defun outline-move-subtree-down (&optional arg)
512      "Move the currrent subtree down past ARG headlines of the same level."
513      (interactive "p")
514      (let ((re (concat "^" outline-regexp))
515            (movfunc (if (> arg 0) 'outline-get-next-sibling
516                       'outline-get-last-sibling))
517            (ins-point (make-marker))
518            (cnt (abs arg))
519            beg end txt folded)
520        ;; Select the tree
521        (outline-back-to-heading)
522        (setq beg (point))
523        (save-match-data
524          (save-excursion (outline-end-of-heading)
525                          (setq folded (outline-invisible-p)))
526          (outline-end-of-subtree))
527        (if (= (char-after) ?\n) (forward-char 1))
528        (setq end (point))
529        ;; Find insertion point, with error handling
530        (goto-char beg)
531        (while (> cnt 0)
532          (or (funcall movfunc)
533              (progn (goto-char beg)
534                     (error "Cannot move past superior level")))
535          (setq cnt (1- cnt)))
536        (if (> arg 0)
537            ;; Moving forward - still need to move over subtree
538            (progn (outline-end-of-subtree)
539                   (if (= (char-after) ?\n) (forward-char 1))))
540        (move-marker ins-point (point))
541        (insert (delete-and-extract-region beg end))
542        (goto-char ins-point)
543        (if folded (hide-subtree))
544        (move-marker ins-point nil)))
545    
546  (defun outline-end-of-heading ()  (defun outline-end-of-heading ()
547    (if (re-search-forward outline-heading-end-regexp nil 'move)    (if (re-search-forward outline-heading-end-regexp nil 'move)
# Line 484  A heading line is one that starts with a Line 566  A heading line is one that starts with a
566      (while (and (not (eobp))      (while (and (not (eobp))
567                  (re-search-forward (concat "^\\(?:" outline-regexp "\\)")                  (re-search-forward (concat "^\\(?:" outline-regexp "\\)")
568                                     nil 'move)                                     nil 'move)
569                  (save-excursion                  (outline-invisible-p (match-beginning 0))))
                   (goto-char (match-beginning 0))  
                   (outline-invisible-p))))  
570      (setq arg (1- arg)))      (setq arg (1- arg)))
571    (beginning-of-line))    (beginning-of-line))
572    
# Line 534  If FLAG is nil then text is shown, while Line 614  If FLAG is nil then text is shown, while
614          ;; reveal do the rest, by simply doing:          ;; reveal do the rest, by simply doing:
615          ;; (remove-overlays (overlay-start o) (overlay-end o)          ;; (remove-overlays (overlay-start o) (overlay-end o)
616          ;;                  'invisible 'outline)          ;;                  'invisible 'outline)
617          ;;          ;;
618          ;; That works fine as long as everything is in sync, but if the          ;; That works fine as long as everything is in sync, but if the
619          ;; structure of the document is changed while revealing parts of it,          ;; structure of the document is changed while revealing parts of it,
620          ;; the resulting behavior can be ugly.  I.e. we need to make          ;; the resulting behavior can be ugly.  I.e. we need to make
# Line 681  Show the heading too, if it is currently Line 761  Show the heading too, if it is currently
761    "Show or hide the current subtree depending on its current state."    "Show or hide the current subtree depending on its current state."
762    (interactive)    (interactive)
763    (outline-back-to-heading)    (outline-back-to-heading)
764    (if (save-excursion    (if (not (outline-invisible-p (line-end-position)))
         (end-of-line)  
         (not (outline-invisible-p)))  
765        (hide-subtree)        (hide-subtree)
766      (show-children)      (show-children)
767      (show-entry)))      (show-entry)))
# Line 754  Default is enough to cause the following Line 832  Default is enough to cause the following
832                                         (point))                                         (point))
833                                       (progn (outline-end-of-heading) (point))                                       (progn (outline-end-of-heading) (point))
834                                       nil)))))))                                       nil)))))))
835    (run-hooks 'outline-view-change-hook))      (run-hooks 'outline-view-change-hook))
836    
837    
838    
# Line 801  Stop at the first and last subheadings o Line 879  Stop at the first and last subheadings o
879      (while (and (> (funcall outline-level) level)      (while (and (> (funcall outline-level) level)
880                  (not (eobp)))                  (not (eobp)))
881        (outline-next-visible-heading 1))        (outline-next-visible-heading 1))
882      (if (< (funcall outline-level) level)      (if (or (eobp) (< (funcall outline-level) level))
883          nil          nil
884        (point))))        (point))))
885    

Legend:
Removed from v.1.60  
changed lines
  Added in v.1.61

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