123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568 |
- (require 'outline)
- (if (not (boundp 'outline-minor-mode))
- (error "Can't find outline-minor-mode"))
- (defvar foldout-fold-list nil
- "List of start and end markers for the folds currently entered.
- An end marker of nil means the fold ends after (point-max).")
- (make-variable-buffer-local 'foldout-fold-list)
- (defvar foldout-modeline-string nil
- "Modeline string announcing that we are in an outline fold.")
- (make-variable-buffer-local 'foldout-modeline-string)
- (or (assq 'foldout-modeline-string minor-mode-alist)
- (let ((outl-entry (memq (assq 'outline-minor-mode minor-mode-alist)
- minor-mode-alist))
- (foldout-entry '((foldout-modeline-string foldout-modeline-string))))
-
- (if (null outl-entry)
- (error "Can't find outline-minor-mode in minor-mode-alist"))
-
- (setcdr outl-entry (nconc foldout-entry (cdr outl-entry)))
- ))
- (defconst foldout-hide-flag
- (if (featurep 'noutline) t ?\))
- (defconst foldout-show-flag
- (if (featurep 'noutline) nil ?\n))
- (defun foldout-zoom-subtree (&optional exposure)
- "Open the subtree under the current heading and narrow to it.
- Normally the body and the immediate subheadings are exposed, but
- optional arg EXPOSURE \(interactively with prefix arg\) changes this:-
- EXPOSURE > 0 exposes n levels of subheadings (c.f. show-children)
- EXPOSURE < 0 exposes only the body
- EXPOSURE = 0 exposes the entire subtree"
- (interactive "P")
- (save-excursion
- (widen)
- (outline-back-to-heading)
- (let* ((exposure-value (prefix-numeric-value exposure))
- (start (point))
- (start-marker (point-marker))
- (end (progn (outline-end-of-subtree)
- (skip-chars-forward "\n\^M")
- (point)))
-
-
-
-
-
- (end-marker (if (eobp) nil (set-marker (make-marker) (1+ end))))
- )
-
- (narrow-to-region start end)
-
- (goto-char start)
- (cond
- ((null exposure)
- (show-entry)
- (show-children))
- ((< exposure-value 0)
- (show-entry))
- ((consp exposure)
- (show-children))
- ((> exposure-value 0)
- (show-children exposure-value))
- (t
- (show-subtree))
- )
-
- (setq foldout-fold-list (cons (cons start-marker end-marker)
- foldout-fold-list))
-
- (foldout-update-modeline)
- )))
- (defun foldout-exit-fold (&optional num-folds)
- "Return to the ARG'th enclosing fold view. With ARG = 0 exit all folds.
- Normally causes exited folds to be hidden, but with ARG < 0, -ARG folds are
- exited and text is left visible."
- (interactive "p")
- (let ((hide-fold t) start-marker end-marker
- beginning-of-heading end-of-subtree)
-
- (if (null foldout-fold-list)
- (error "Not in a fold!"))
- (cond
-
- ((zerop num-folds)
- (setq num-folds (length foldout-fold-list)))
-
- ((< num-folds 0)
- (setq hide-fold nil
- num-folds (- num-folds)))
- )
-
- (setq num-folds (min num-folds (length foldout-fold-list)))
-
- (widen)
- (while (not (zerop num-folds))
-
- (setq start-marker (car (car foldout-fold-list))
- end-marker (cdr (car foldout-fold-list))
- foldout-fold-list (cdr foldout-fold-list)
- num-folds (1- num-folds))
-
-
-
- (if end-marker
- (progn
- (goto-char end-marker)
- (forward-char -1)
- (or (memq (preceding-char) '(?\n ?\))
- (insert ?\n))))
-
-
-
-
-
-
-
- (when (zerop num-folds)
- (if end-marker
- (setq beginning-of-heading (point)
- end-of-subtree (progn (forward-char -1)
- (if (memq (preceding-char)
- '(?\n ?\))
- (forward-char -1))
- (point))))
-
- (when hide-fold
- (goto-char start-marker)
- (hide-subtree))
-
- (if end-marker
- (outline-flag-region end-of-subtree beginning-of-heading
- foldout-show-flag)))
-
- (set-marker start-marker nil)
- (if end-marker (set-marker end-marker nil))
- )
-
- (if foldout-fold-list
- (progn
- (setq start-marker (car (car foldout-fold-list))
- end-marker (cdr (car foldout-fold-list)))
- (narrow-to-region start-marker
- (if end-marker
- (1- (marker-position end-marker))
- (point-max)))
- ))
- (recenter)
-
- (foldout-update-modeline)
- ))
- (defun foldout-update-modeline ()
- "Set the modeline string to indicate our fold depth."
- (let ((depth (length foldout-fold-list)))
- (setq foldout-modeline-string
- (cond
-
- ((zerop depth)
- nil)
-
- (outline-minor-mode
- (format ":%d" depth))
-
- ((= depth 1)
- " Inside 1 fold")
- (t
- (format " Inside %d folds" depth))
- ))))
- (defun foldout-mouse-zoom (event)
- "Zoom in on the heading clicked on.
- How much is exposed by the zoom depends on the number of mouse clicks:-
- 1 expose body
- 2 expose subheadings
- 3 expose body and subheadings
- 4 expose entire subtree"
- (interactive "@e")
-
- (setq event (foldout-mouse-swallow-events event))
-
- (foldout-mouse-goto-heading event)
-
- (foldout-zoom-subtree
- (let ((nclicks (event-click-count event)))
- (cond
- ((= nclicks 1) -1)
- ((= nclicks 2) '(1))
- ((= nclicks 3) nil)
- (t 0)))))
- (defun foldout-mouse-show (event)
- "Show what is hidden under the heading clicked on.
- What gets exposed depends on the number of mouse clicks:-
- 1 expose body
- 2 expose subheadings
- 3 expose body and subheadings
- 4 expose entire subtree"
- (interactive "@e")
-
- (setq event (foldout-mouse-swallow-events event))
-
- (foldout-mouse-goto-heading event)
- (let ((nclicks (event-click-count event)))
- (cond
- ((= nclicks 1) (show-entry))
- ((= nclicks 2) (show-children))
- ((= nclicks 3) (show-entry) (show-children))
- (t (show-subtree)))))
- (defun foldout-mouse-hide-or-exit (event)
- "Hide the subtree under the heading clicked on, or exit a fold.
- What happens depends on the number of mouse clicks:-
- 1 hide subtree
- 2 exit fold and hide text
- 3 exit fold without hiding text
- 4 exit all folds and hide text"
- (interactive "@e")
-
- (setq event (foldout-mouse-swallow-events event))
-
- (let ((nclicks (event-click-count event)))
- (if (= nclicks 1)
- (progn
- (foldout-mouse-goto-heading event)
- (hide-subtree))
- (foldout-exit-fold
- (cond
- ((= nclicks 2) 1)
- ((= nclicks 3) -1)
- (t 0))))))
- (defun foldout-mouse-swallow-events (event)
- "Swallow intervening mouse events so we only get the final click-count.
- Signal an error if the final event isn't the same type as the first one."
- (let ((initial-event-type (event-basic-type event)))
- (while (null (sit-for (/ double-click-time 1000.0) 'nodisplay))
- (setq event (read-event)))
- (or (eq initial-event-type (event-basic-type event))
- (error "")))
- event)
- (defun foldout-mouse-goto-heading (event)
- "Go to the heading where the mouse event started. Signal an error
- if the event didn't occur on a heading."
- (goto-char (posn-point (event-start event)))
- (or (outline-on-heading-p)
-
-
- (save-excursion (beginning-of-line) (bobp))
- (error "Not a heading line")))
- (defvar foldout-inhibit-key-bindings nil
- "Set non-nil before loading foldout to inhibit key bindings.")
- (defvar foldout-mouse-modifiers '(meta control)
- "List of modifier keys to apply to foldout's mouse events.
- The default (meta control) makes foldout bind its functions to
- M-C-down-mouse-{1,2,3}.
- Valid modifiers are shift, control, meta, alt, hyper and super.")
- (if foldout-inhibit-key-bindings
- ()
- (define-key outline-mode-map "\C-c\C-z" 'foldout-zoom-subtree)
- (define-key outline-mode-map "\C-c\C-x" 'foldout-exit-fold)
- (let ((map (lookup-key outline-minor-mode-map outline-minor-mode-prefix)))
- (unless map
- (setq map (make-sparse-keymap))
- (define-key outline-minor-mode-map outline-minor-mode-prefix map))
- (define-key map "\C-z" 'foldout-zoom-subtree)
- (define-key map "\C-x" 'foldout-exit-fold))
- (let* ((modifiers (apply 'concat
- (mapcar (function
- (lambda (modifier)
- (vector
- (cond
- ((eq modifier 'shift) ?S)
- ((eq modifier 'control) ?C)
- ((eq modifier 'meta) ?M)
- ((eq modifier 'alt) ?A)
- ((eq modifier 'hyper) ?H)
- ((eq modifier 'super) ?s)
- (t (error "invalid mouse modifier %s"
- modifier)))
- ?-)))
- foldout-mouse-modifiers)))
- (mouse-1 (vector (intern (concat modifiers "down-mouse-1"))))
- (mouse-2 (vector (intern (concat modifiers "down-mouse-2"))))
- (mouse-3 (vector (intern (concat modifiers "down-mouse-3")))))
- (define-key outline-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-mode-map mouse-3 'foldout-mouse-hide-or-exit)
- (define-key outline-minor-mode-map mouse-1 'foldout-mouse-zoom)
- (define-key outline-minor-mode-map mouse-2 'foldout-mouse-show)
- (define-key outline-minor-mode-map mouse-3 'foldout-mouse-hide-or-exit)
- ))
- (provide 'foldout)
|