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 |
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] |
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))) |
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))) |
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) |
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 |
|
|
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 |
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))) |
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 |
|
|
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 |
|
|