(define-key map "\C-k" 'show-branches)
(define-key map "\C-q" 'hide-sublevels)
(define-key map "\C-o" 'hide-other)
- (define-key map "\C-^" 'outline-promote)
- (define-key map "\C-v" 'outline-demote)
- ;; Where to bind toggle and insert-heading ?
+ (define-key map "\C-^" 'outline-move-subtree-up)
+ (define-key map "\C-v" 'outline-move-subtree-down)
+ (define-key map [(control ?<)] 'outline-promote)
+ (define-key map [(control ?>)] 'outline-demote)
+ (define-key map "\C-m" 'outline-insert-heading)
+ ;; Where to bind outline-cycle ?
map))
(defvar outline-mode-menu-bar-map
(define-key map [headings]
(cons "Headings" (make-sparse-keymap "Headings")))
+ (define-key map [headings demote-subtree]
+ '(menu-item "Demote subtree" outline-demote))
+ (define-key map [headings promote-subtree]
+ '(menu-item "Promote subtree" outline-promote))
+ (define-key map [headings move-subtree-down]
+ '(menu-item "Move subtree down" outline-move-subtree-down))
+ (define-key map [headings move-subtree-up]
+ '(menu-item "Move subtree up" outline-move-subtree-up))
(define-key map [headings copy]
'(menu-item "Copy to kill ring" outline-headers-as-kill
:enable mark-active))
+ (define-key map [headings outline-insert-heading]
+ '("New heading" . outline-insert-heading))
(define-key map [headings outline-backward-same-level]
'("Previous Same Level" . outline-backward-same-level))
(define-key map [headings outline-forward-same-level]
(cons '(--- "---") (cdr x))))
outline-mode-menu-bar-map))))))
map))
-
+
(defvar outline-mode-map
(let ((map (make-sparse-keymap)))
(re-search-backward (concat "^\\(?:" outline-regexp "\\)")
nil 'move))
-(defsubst outline-invisible-p ()
+(defsubst outline-invisible-p (&optional pos)
"Non-nil if the character after point is invisible."
- (get-char-property (point) 'invisible))
+ (get-char-property (or pos (point)) 'invisible))
(defun outline-visible ()
(not (outline-invisible-p)))
(run-hooks 'outline-insert-heading-hook)))
(defun outline-promote (&optional children)
- "Promote the current heading higher up the tree.
-If prefix argument CHILDREN is given, promote also all the children."
- (interactive "P")
- (outline-back-to-heading)
- (let* ((head (match-string 0))
- (level (save-match-data (funcall outline-level)))
- (up-head (or (car (rassoc (1- level) outline-heading-alist))
- (save-excursion
- (save-match-data
- (outline-up-heading 1 t)
- (match-string 0))))))
-
- (unless (rassoc level outline-heading-alist)
- (push (cons head level) outline-heading-alist))
-
- (replace-match up-head nil t)
- (when children
- (outline-map-tree 'outline-promote level))))
+ "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."
+ (interactive
+ (list (if (and transient-mark-mode mark-active) 'region
+ (outline-back-to-heading)
+ (if current-prefix-arg nil 'subtree))))
+ (cond
+ ((eq children 'region)
+ (outline-map-region 'outline-promote (region-beginning) (region-end)))
+ (children
+ (outline-map-region 'outline-promote
+ (point)
+ (save-excursion (outline-get-next-sibling) (point))))
+ (t
+ (outline-back-to-heading t)
+ (let* ((head (match-string 0))
+ (level (save-match-data (funcall outline-level)))
+ (up-head (or (car (rassoc (1- level) outline-heading-alist))
+ (save-excursion
+ (save-match-data
+ (outline-up-heading 1 t)
+ (match-string 0))))))
+
+ (unless (rassoc level outline-heading-alist)
+ (push (cons head level) outline-heading-alist))
+
+ (replace-match up-head nil t)))))
(defun outline-demote (&optional children)
- "Demote the current heading lower down the tree.
-If prefix argument CHILDREN is given, demote also all the children."
- (interactive "P")
- (outline-back-to-heading)
- (let* ((head (match-string 0))
- (level (save-match-data (funcall outline-level)))
- (down-head
- (or (car (rassoc (1+ level) outline-heading-alist))
- (save-excursion
- (save-match-data
- (while (and (not (eobp))
- (progn
- (outline-next-heading)
- (<= (funcall outline-level) level))))
- (when (eobp)
- ;; Try again from the beginning of the buffer.
- (goto-char (point-min))
+ "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."
+ (interactive
+ (list (if (and transient-mark-mode mark-active) 'region
+ (outline-back-to-heading)
+ (if current-prefix-arg nil 'subtree))))
+ (cond
+ ((eq children 'region)
+ (outline-map-region 'outline-demote (region-beginning) (region-end)))
+ (children
+ (outline-map-region 'outline-demote
+ (point)
+ (save-excursion (outline-get-next-sibling) (point))))
+ (t
+ (let* ((head (match-string 0))
+ (level (save-match-data (funcall outline-level)))
+ (down-head
+ (or (car (rassoc (1+ level) outline-heading-alist))
+ (save-excursion
+ (save-match-data
(while (and (not (eobp))
(progn
(outline-next-heading)
- (<= (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 of lower level ?
- new-head
- ;; Didn't work: keep it as is so it's still a heading.
- head))))))
+ (<= (funcall outline-level) level))))
+ (when (eobp)
+ ;; Try again from the beginning of the buffer.
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (progn
+ (outline-next-heading)
+ (<= (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)))))
- (replace-match down-head nil t)
- (when children
- (outline-map-tree 'outline-demote level))))
-
-(defun outline-map-tree (fun level)
- "Call FUN for every heading underneath the current one."
+(defun outline-map-region (fun beg end)
+ "Call FUN for every heading between BEG and END.
+When FUN is called, point is at the beginning of the heading and
+the match data is set appropriately."
(save-excursion
- (while (and (progn
- (outline-next-heading)
- (> (funcall outline-level) level))
- (not (eobp)))
- (funcall fun))))
+ (setq end (copy-marker end))
+ (goto-char beg)
+ (when (re-search-forward (concat "^\\(?:" outline-regexp "\\)") end t)
+ (goto-char (match-beginning 0))
+ (funcall fun)
+ (while (and (progn
+ (outline-next-heading)
+ (< (point) end))
+ (not (eobp)))
+ (funcall fun)))))
+
+;; Vertical tree motion
+
+(defun outline-move-subtree-up (&optional arg)
+ "Move the currrent subtree up past ARG headlines of the same level."
+ (interactive "p")
+ (outline-move-subtree-down (- arg)))
+
+(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
+ 'outline-get-last-sibling))
+ (ins-point (make-marker))
+ (cnt (abs arg))
+ beg end txt folded)
+ ;; Select the tree
+ (outline-back-to-heading)
+ (setq beg (point))
+ (save-match-data
+ (save-excursion (outline-end-of-heading)
+ (setq folded (outline-invisible-p)))
+ (outline-end-of-subtree))
+ (if (= (char-after) ?\n) (forward-char 1))
+ (setq end (point))
+ ;; Find insertion point, with error handling
+ (goto-char beg)
+ (while (> cnt 0)
+ (or (funcall movfunc)
+ (progn (goto-char beg)
+ (error "Cannot move past superior level")))
+ (setq cnt (1- cnt)))
+ (if (> arg 0)
+ ;; Moving forward - still need to move over subtree
+ (progn (outline-end-of-subtree)
+ (if (= (char-after) ?\n) (forward-char 1))))
+ (move-marker ins-point (point))
+ (insert (delete-and-extract-region beg end))
+ (goto-char ins-point)
+ (if folded (hide-subtree))
+ (move-marker ins-point nil)))
(defun outline-end-of-heading ()
(if (re-search-forward outline-heading-end-regexp nil 'move)
(while (and (not (eobp))
(re-search-forward (concat "^\\(?:" outline-regexp "\\)")
nil 'move)
- (save-excursion
- (goto-char (match-beginning 0))
- (outline-invisible-p))))
+ (outline-invisible-p (match-beginning 0))))
(setq arg (1- arg)))
(beginning-of-line))
;; reveal do the rest, by simply doing:
;; (remove-overlays (overlay-start o) (overlay-end o)
;; 'invisible 'outline)
- ;;
+ ;;
;; That works fine as long as everything is in sync, but if the
;; structure of the document is changed while revealing parts of it,
;; the resulting behavior can be ugly. I.e. we need to make
"Show or hide the current subtree depending on its current state."
(interactive)
(outline-back-to-heading)
- (if (save-excursion
- (end-of-line)
- (not (outline-invisible-p)))
+ (if (not (outline-invisible-p (line-end-position)))
(hide-subtree)
(show-children)
(show-entry)))
(point))
(progn (outline-end-of-heading) (point))
nil)))))))
- (run-hooks 'outline-view-change-hook))
+ (run-hooks 'outline-view-change-hook))
\f
(while (and (> (funcall outline-level) level)
(not (eobp)))
(outline-next-visible-heading 1))
- (if (< (funcall outline-level) level)
+ (if (or (eobp) (< (funcall outline-level) level))
nil
(point))))
projects / emacs.git / commitdiff