(defconst folding-version-time "2014.0401.0703"
"Last edit time in format YYYY.MMDD.HHMM.")
(eval-when-compile
(require 'cl))
(eval-and-compile
(autoload 'font-lock-fontify-region "font-lock")
(defvar global-font-lock-mode))
(require 'easymenu)
(defvar folding-package-url-location
"Latest folding is available at http://cvs.xemacs.org/viewcvs.cgi/XEmacs/packages/xemacs-packages/text-modes/")
(eval-and-compile
(require 'advice)
(defvar folding-xemacs-p (or (boundp 'xemacs-logo)
(featurep 'xemacs))
"Folding determines which emacs version it is running. t if Xemacs.")
(if folding-xemacs-p
(or (fboundp 'overlay-start) (load "overlay" 'noerr) (message "\
** folding.el: XEmacs 19.15+ has package overlay.el, try to get it.
This is only warning. Folding does not use overlays by
default. You can safely ignore possible overlay byte
compilation error
messages."))))
(eval-when-compile
(when nil (if (string= (buffer-name) " *Compiler Input*")
(progn
(message "** folding.el:\
Info, Ignore [X]Emacs's missing motion/event/posn functions calls"))))
(defadvice find-function-search-for-symbol (around folding act)
"Set folding flag for `find-file-noselect' to open all folds."
(let ((file (ad-get-arg 2)))
(when file
(message "FILE %s" file)
(put 'find-file-noselect 'folding file)))
ad-do-it
(put 'find-file-noselect 'folding nil))
(defun folding-find-file-noselect ()
(let* ((file (get 'find-file-noselect 'folding))
(buffer (and file
(or (find-buffer-visiting file)
(get-buffer file)
(get-buffer (concat file ".el"))))))
(when buffer
(with-current-buffer buffer
(when (symbol-value 'folding-mode) (turn-off-folding-mode))))))
(defadvice find-file-noselect (after folding act)
"When called by `find-function-search-for-symbol', turn folding off."
(folding-find-file-noselect))
(defadvice make-sparse-keymap
(before
make-sparse-keymap-with-optional-argument
(&optional byte-compiler-happyfier)
activate)
"This advice does nothing except adding an optional argument
to keep the byte compiler happy when compiling Emacs specific code
with XEmacs.")
(and (boundp 'mode-line-format)
(put 'mode-line-format 'byte-obsolete-variable nil))
(and (fboundp 'byte-code-function-p)
(put 'byte-code-function-p 'byte-compile nil))
(and (fboundp 'eval-current-buffer)
(put 'eval-current-buffer 'byte-compile nil)))
(defsubst folding-preserve-active-region ()
"In XEmacs keep the region alive. In Emacs do nothing."
(if (boundp 'zmacs-region-stays) (set 'zmacs-region-stays t)))
(eval-and-compile
(when (and (not folding-xemacs-p)
(memq (symbol-value 'window-system) '(win32 w32)) (string< emacs-version "20.4"))
(unless (fboundp 'char-equal)
(defalias 'char-equal 'equal))
(unless (fboundp 'subst-char)
(defun subst-char (str char to-char)
"Replace in STR every CHAR with TO-CHAR."
(let ((len (length str))
(ret (copy-sequence str))) (while (> len 0)
(if (char-equal (aref str (1- len)) char)
(aset ret (1- len) to-char))
(decf len))
ret)))
(defadvice kill-new (around folding-win32-fix-selective-display act)
"In selective display, convert each C-m to C-a. See `current-kill'."
(let* ((string (ad-get-arg 0)))
(when (and selective-display (string-match "\C-m" (or string "")))
(setq string (subst-char string ?\C-m ?\C-a)))
ad-do-it))
(defadvice current-kill (around folding-win32-fix-selective-display act)
"In selective display, convert each C-a back to C-m. See `kill-new'."
ad-do-it
(let* ((string ad-return-value))
(when (and selective-display (string-match "\C-a" (or string "")))
(setq string (subst-char string ?\C-a ?\C-m))
(setq ad-return-value string))))))
(defvar folding-mode)
(when (locate-library "mode-motion") (defun folding-mode-motion-highlight-fold (event)
"Highlight line under mouse if it has a foldmark."
(when folding-mode
(funcall
(symbol-function 'mode-motion-highlight-internal)
event
(function
(lambda ()
(beginning-of-line)
(if (folding-mark-look-at)
(search-forward-regexp "^[ \t]*"))))
(function
(lambda ()
(if (folding-mark-look-at)
(end-of-line)))))))
(require 'mode-motion)
(add-hook 'mode-motion-hook 'folding-mode-motion-highlight-fold 'at-end))
(defvar folding-stack nil
"Internal. A list of marker pairs representing folds entered so far.")
(defvar folding-version (substring "$Revision: 3.42 $" 11 15)
"Version number of folding.el.")
(defgroup folding nil
"Managing buffers with Folds."
:group 'tools)
(defcustom folding-mode-prefix-key "\C-c@"
"*Prefix key to use for Folding commands in Folding mode."
:type 'string
:group 'folding)
(defcustom folding-goto-key "\M-g"
"*Key to be bound to `folding-goto-line' in folding mode.
The default value is M - g, but you probably don't want folding to
occupy it if you have used M - g got `goto-line'."
:type 'string
:group 'folding)
(defcustom folding-font-lock-begin-mark 'font-lock-reference-face
"Face to highlight beginning fold mark."
:type 'face
:group 'folding)
(defcustom folding-font-lock-end-mark 'font-lock-reference-face
"Face to highlight end fold mark."
:type 'face
:group 'folding)
(defvar folding-mode-map nil
"Keymap used in Folding mode (a minor mode).")
(defvar folding-mode-prefix-map nil
"Keymap used in Folding mode keys sans `folding-mode-prefix-key'.")
(defvar folding-mode nil
"When Non nil, Folding mode is active in the current buffer.")
(make-variable-buffer-local 'folding-mode)
(set-default 'folding-mode nil)
(defmacro folding-kbd (key function)
"Folding: define KEY with FUNCTION to `folding-mode-prefix-map'.
This is used when assigning keybindings to `folding-mode-map'.
See also `folding-mode-prefix-key'."
`(define-key
folding-mode-prefix-map
,key ,function))
(defun folding-bind-default-mouse ()
"Bind default mouse keys used by Folding mode."
(interactive)
(cond
(folding-xemacs-p
(define-key folding-mode-map [(button3)]
'folding-mouse-context-sensitive)
(define-key folding-mode-map [(control shift button2)]
'folding-mouse-pick-move))
(t
(define-key folding-mode-map [mouse-3] 'folding-mouse-context-sensitive)
(define-key folding-mode-map [C-S-mouse-2] 'folding-mouse-pick-move))))
(defun folding-bind-terminal-keys ()
"In non-window system, rebind C - f and C - b as folding-{forward,backward}-char."
(unless (or (and (boundp 'window-system) (symbol-value 'window-system)) (and (fboundp 'console-type) (let ((val (fboundp 'console-type)))
(not (eq 'tty val)))))
(define-key folding-mode-map "\C-f" 'folding-forward-char)
(define-key folding-mode-map "\C-b" 'folding-backward-char)))
(defun folding-bind-default-keys ()
"Bind the default keys used the `folding-mode'.
The variable `folding-mode-prefix-key' contains the prefix keys,
the default is C - c @.
For the good ol' key bindings, please use the function
`folding-bind-backward-compatible-keys' instead."
(interactive)
(define-key folding-mode-map folding-goto-key 'folding-goto-line)
(folding-bind-terminal-keys)
(define-key folding-mode-map "\C-e" 'folding-end-of-line)
(folding-kbd "\C-f" 'folding-fold-region)
(folding-kbd ">" 'folding-shift-in)
(folding-kbd "<" 'folding-shift-out)
(folding-kbd "\C-t" 'folding-show-all)
(folding-kbd "\C-s" 'folding-show-current-entry)
(folding-kbd "\C-x" 'folding-hide-current-entry)
(folding-kbd "\C-o" 'folding-open-buffer)
(folding-kbd "\C-w" 'folding-whole-buffer)
(folding-kbd "\C-r" 'folding-convert-buffer-for-printing)
(folding-kbd "\C-k" 'folding-marks-kill)
(folding-kbd "\C-v" 'folding-pick-move)
(folding-kbd "v" 'folding-previous-visible-heading)
(folding-kbd " " 'folding-next-visible-heading)
(folding-kbd "." 'folding-context-next-action)
(folding-kbd "\C-u" 'folding-toggle-enter-exit)
(folding-kbd "\C-q" 'folding-toggle-show-hide)
(folding-kbd "#" 'folding-region-open-close)
(folding-kbd ";" 'folding-comment-fold)
(folding-kbd "%" 'folding-convert-to-major-folds)
(folding-kbd "/" 'folding-all-comment-blocks-in-region)
(folding-kbd "\C-y" 'folding-show-current-subtree)
(folding-kbd "\C-z" 'folding-hide-current-subtree)
(folding-kbd "\C-n" 'folding-display-name)
(folding-kbd "I" 'folding-insert-advertise-folding-mode))
(defun folding-bind-backward-compatible-keys ()
"Bind keys traditionally used by Folding mode.
For bindings which follow newer Emacs minor mode conventions, please
use the function `folding-bind-default-keys'.
This function sets `folding-mode-prefix-key' to `C-c'."
(interactive)
(setq folding-mode-prefix-key "\C-c")
(folding-bind-default-keys))
(defun folding-bind-outline-compatible-keys ()
"Bind keys used by the minor mode `folding-mode'.
The keys used are as much as possible compatible with
bindings used by Outline mode.
Currently, some outline mode functions doesn't have a corresponding
folding function.
The variable `folding-mode-prefix-key' contains the prefix keys,
the default is C - c @.
For the good ol' key bindings, please use the function
`folding-bind-backward-compatible-keys' instead."
(interactive)
(folding-bind-terminal-keys)
(define-key folding-mode-map "\C-e" 'folding-end-of-line)
(folding-kbd ">" 'folding-shift-in)
(folding-kbd "<" 'folding-shift-out)
(folding-kbd "\C-n" 'folding-next-visible-heading)
(folding-kbd "\C-p" 'folding-previous-visible-heading)
(folding-kbd "\C-s" 'folding-show-current-subtree)
(folding-kbd "\C-h" 'folding-hide-current-subtree)
(folding-kbd "\C-k" 'folding-marks-kill)
(folding-kbd "!" 'folding-show-all)
(folding-kbd "\C-d" 'folding-hide-current-entry)
(folding-kbd "\C-o" 'folding-show-current-entry)
(folding-kbd "\C-a" 'folding-open-buffer)
(folding-kbd "\C-q" 'folding-whole-buffer)
(folding-kbd "\C-r" 'folding-convert-buffer-for-printing)
(folding-kbd "\C-w" 'folding-fold-region)
(folding-kbd "I" 'folding-insert-advertise-folding-mode))
(defcustom folding-advice-instantiate t
"*In non-nil install advice code. Eg for `goto-line'."
:type 'boolean
:group 'folding)
(defcustom folding-shift-in-on-goto t
"*Flag in folding adviced function `goto-line'.
If non-nil, folds are entered when going to a given line.
Otherwise the buffer is unfolded. Can also be set to 'show.
This variable is used only if `folding-advice-instantiate' was
non-nil when folding was loaded.
See also `folding-goto-key'."
:type 'boolean
:group 'folding)
(defvar folding-narrow-by-default t
"If t (default) things like isearch will enter folds. If nil the
folds will be opened, but not entered.")
(when folding-advice-instantiate
(eval-when-compile (require 'advice))
(defadvice goto-line (around folding-goto-line first activate)
"Go to line ARG, entering folds if `folding-shift-in-on-goto' is t.
It attempts to keep the buffer in the same visibility state as before."
(let () ad-do-it
(if (and folding-mode
(or (folding-point-folded-p (point))
(<= (point) (point-min-marker))
(>= (point) (point-max-marker))))
(let ((line (ad-get-arg 0)))
(if folding-shift-in-on-goto
(progn
(folding-show-all)
(goto-char 1)
(and (< 1 line)
(not (folding-use-overlays-p))
(re-search-forward "[\n\C-m]" nil 0 (1- line)))
(let ((goal (point)))
(while (prog2 (beginning-of-line)
(if folding-shift-in-on-goto
(progn
(folding-show-current-entry t t)
(folding-point-folded-p goal))
(folding-shift-in t))
(goto-char goal)))
(folding-narrow-to-region
(and folding-narrow-by-default (point-min))
(point-max) t)))
(if (or folding-stack (folding-point-folded-p (point)))
(folding-open-buffer))))))))
(defun folding-bind-foldout-compatible-keys ()
"Bind keys for `folding-mode' compatible with Foldout mode.
The variable `folding-mode-prefix-key' contains the prefix keys,
the default is C - c @."
(interactive)
(folding-kbd "\C-z" 'folding-shift-in)
(folding-kbd "\C-x" 'folding-shift-out))
(defvar folding-saved-local-keymap nil
"Keymap used to save non-folding keymap.
(so it can be restored when folding mode is turned off.)")
(defcustom folding-default-keys-function 'folding-bind-default-keys
"*Function or list of functions used to define keys for Folding mode.
Possible values are:
folding-bind-default-key
The standard keymap.
`folding-bind-backward-compatible-keys'
Keys used by older versions of Folding mode. This function
does not conform to Emacs 19.29 style conversions concerning
key bindings. The prefix key is C - c
`folding-bind-outline-compatible-keys'
Define keys compatible with Outline mode.
`folding-bind-foldout-compatible-keys'
Define some extra keys compatible with Foldout.
All except `folding-bind-backward-compatible-keys' used the value of
the variable `folding-mode-prefix-key' as prefix the key.
The default is C - c @"
:type 'function
:group 'folding)
(defcustom folding-default-mouse-keys-function 'folding-bind-default-mouse
"*Function to bind default mouse keys to `folding-mode-map'."
:type 'function
:group 'folding)
(defvar folding-mode-menu nil
"Keymap containing the menu for Folding mode.")
(defvar folding-mode-menu-name "Fld" "Name of pull down menu.")
(defcustom folding-mode-hook nil
"*Hook called when Folding mode is entered.
A hook named `<major-mode>-folding-hook' is also called, if it
exists. Eg., `c-mode-folding-hook' is called whenever Folding mode is
started in C mode."
:type 'hook
:group 'folding)
(defcustom folding-load-hook nil
"*Hook run when file is loaded."
:type 'hook
:group 'folding)
(defvar folding-mouse-yank-at-point t
"If non-nil, mouse activities are done at point instead of 'mouse cursor'.
Behaves like `mouse-yank-at-point'.")
(defcustom folding-folding-on-startup t
"*If non-nil, buffers are folded when starting Folding mode."
:type 'boolean
:group 'folding)
(defcustom folding-internal-margins 1
"*Number of blank lines left next to fold mark when tidying folds.
This variable is local to each buffer. To set the default value for all
buffers, use `set-default'.
When exiting a fold, and at other times, `folding-tidy-inside' is invoked
to ensure that the fold is in the correct form before leaving it. This
variable specifies the number of blank lines to leave between the
enclosing fold marks and the enclosed text.
If this value is nil or negative, no blank lines are added or removed
inside the fold marks. A value of 0 (zero) is valid, meaning leave no
blank lines.
See also `folding-tidy-inside'."
:type 'boolean
:group 'folding)
(make-variable-buffer-local 'folding-internal-margins)
(defvar folding-mode-string " Fld"
"Buffer-local variable that hold the fold depth description.")
(set-default 'folding-mode-string " Fld")
(defconst folding-inside-string " " "Mode line addition to show 'inside' levels of fold.")
(defcustom folding-inside-mode-name "Fld"
"*Mode line addition to show inside levels of 'fold' ."
:type 'string
:group 'folding)
(defcustom folding-check-folded-file-function
'folding-check-folded
"*Function that return t or nil after examining if the file is folded."
:type 'function
:group 'folding)
(defcustom folding-check-allow-folding-function
'folding-check-if-folding-allowed
"*Function that return t or nil after deciding if automatic folding."
:type 'function
:group 'folding)
(defcustom folding-mode-string "Fld"
"*The minor mode string displayed when mode is on."
:type 'string
:group 'folding)
(defcustom folding-mode-hook-no-regexp "RMAIL"
"*Regexp which disable automatic folding mode turn on for certain files."
:type 'string
:group 'folding)
(defcustom folding-behave-table
'((close folding-hide-current-entry)
(open folding-show-current-entry) (up folding-shift-out)
(other folding-mouse-call-original))
"*Table of of logical commands and their associated functions.
If you want fold to behave like `folding-shift-in', when it 'open'
a fold, you just change the function entry in this table.
Table form:
'( (LOGICAL-ACTION CMD) (..) ..)"
:type '(repeat
(symbol :tag "logical action")
(function :tag "callback"))
:group 'folding)
(defvar folding-mode-marks-alist nil
"List of (major-mode . fold mark) default combinations to use.
When Folding mode is started, the major mode is checked, and if there
are fold marks for that major mode stored in `folding-mode-marks-alist',
those marks are used by default. If none are found, the default values
of \"{{{ \" and \"}}}\" are used.
Use function `folding-add-to-marks-list' to add more fold marks. The function
also explains the alist use in details.
Use function `folding-set-local-variables' if you change the current mode's
folding marks during the session.")
(defvar folding-narrow-placeholder nil
"Internal. Mark where \"%n\" used to be in `mode-line-format'.
Must be nil.")
(defvar folding-bottom-mark nil
"Internal marker of the true bottom of a fold.")
(defvar folding-bottom-regexp nil
"Internal. Regexp marking the bottom of a fold.")
(defvar folding-regexp nil
"Internal. Regexp for hunting down the `folding-top-mark' even in comments.")
(defvar folding-secondary-top-mark nil
"Internal. Additional stuff that can be inserted as part of a top marker.")
(defvar folding-top-mark nil
"Internal. The actual string marking the top of a fold.")
(defvar folding-top-regexp nil
"Internal.
Regexp describing the string beginning a fold, possible with
leading comment thingies and like that.")
(defvar folded-file nil
"Enter folding mode when this file is loaded.
(buffer local, use from a local variables list).")
(defvar folding-calling-original nil
"Internal. Non-nil when original mouse binding is executed.")
(defvar folding-narrow-overlays nil
"Internal. Keep the list of overlays.")
(make-variable-buffer-local 'folding-narrow-overlays)
(defcustom folding-allow-overlays nil
"*If non-nil use overlay code. If nil, then selective display is used.
Note, that this code is highly experimental and will not most likely do what
you expect. using value t will not change folding to use overlays
completely. This variable was introduced to experiment with the overlay
interface, but the work never finished and it is unlikely that it
will continued any later time. Folding at present state is designed
too highly for selective display to make the change worthwhile."
:type 'boolean
:group 'folding)
(defun folding-easy-menu-define ()
"Define folding easy menu."
(interactive)
(easy-menu-define
folding-mode-menu
(if folding-xemacs-p
nil
(list folding-mode-map))
"Folding menu"
(list
folding-mode-menu-name
["Enter Fold" folding-shift-in t]
["Exit Fold" folding-shift-out t]
["Show Fold" folding-show-current-entry t]
["Hide Fold" folding-hide-current-entry t]
"----"
["Show Whole Buffer" folding-open-buffer t]
["Fold Whole Buffer" folding-whole-buffer t]
["Show subtree" folding-show-current-subtree t]
["Hide subtree" folding-hide-current-subtree t]
["Display fold name" folding-display-name t]
"----"
["Move previous" folding-previous-visible-heading t]
["Move next" folding-next-visible-heading t]
["Pick fold" folding-pick-move t]
["Next action (context)" folding-context-next-action t]
"----"
["Foldify region" folding-fold-region t]
["Open or close folds in region" folding-region-open-close t]
["Open folds to top level" folding-show-all t]
"----"
["Comment text in fold" folding-comment-fold t]
["Convert for printing(temp buffer)"
folding-convert-buffer-for-printing t]
["Convert to major-mode folds" folding-convert-to-major-folds t]
["Move comments inside folds in region"
folding-all-comment-blocks-in-region t]
["Delete fold marks in this fold" folding-marks-kill t]
["Insert folding URL reference"
folding-insert-advertise-folding-mode t]
"----"
["Toggle enter and exit mode" folding-toggle-enter-exit t]
["Toggle show and hide" folding-toggle-show-hide t]
"----"
["Folding mode off" folding-mode t])))
(defun folding-install-keymaps ()
"Install keymaps."
(unless folding-mode-map
(setq folding-mode-map (make-sparse-keymap)))
(unless folding-mode-prefix-map
(setq folding-mode-prefix-map (make-sparse-keymap)))
(if (listp folding-default-keys-function)
(mapc 'funcall folding-default-keys-function)
(funcall folding-default-keys-function))
(funcall folding-default-mouse-keys-function)
(folding-easy-menu-define)
(define-key folding-mode-map
folding-mode-prefix-key folding-mode-prefix-map)
(let ((elt (assq 'folding-mode minor-mode-map-alist)))
(if elt
(setq minor-mode-map-alist
(delete elt minor-mode-map-alist)))
(push (cons 'folding-mode folding-mode-map) minor-mode-map-alist))
(or (assq 'folding-mode minor-mode-alist)
(push '(folding-mode folding-mode-string) minor-mode-alist))
(or (fboundp 'buffer-disable-undo)
(fset 'buffer-disable-undo (symbol-function 'buffer-flush-undo))))
(defun folding-uninstall-keymaps ()
"Uninstall keymaps."
(let ((elt (assq 'folding-mode minor-mode-map-alist)))
(if elt
(setq minor-mode-map-alist
(delete elt minor-mode-map-alist)))
(if (setq elt (assq 'folding-mode minor-mode-alist))
(setq minor-mode-alist
(delete elt minor-mode-alist)))
(folding-uninstall-hooks)))
(defun folding-install (&optional uninstall)
"Install or UNINSTALL folding."
(interactive "P")
(cond
(uninstall
(folding-uninstall-keymaps)
(folding-uninstall-hooks))
(t
(folding-install-keymaps))))
(defun folding-uninstall ()
"Uninstall folding."
(interactive)
(folding-install 'uninstall)
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(goto-char (point-min))
(when (or folding-mode
(re-search-forward "{{{" nil t))
(turn-off-folding-mode)))))
(defsubst folding-get-mode-marks (&optional mode)
"Return fold markers for MODE. default is for current `major-mode'.
Return:
\(beg-marker end-marker\)"
(interactive)
(let* (elt)
(unless (setq elt (assq (or mode major-mode)
folding-mode-marks-alist))
(error "Folding error: mode is not in `folding-mode-marks-alist'"))
(list (nth 1 elt) (nth 2 elt) (nth 3 elt))))
(defun folding-region-has-folding-marks-p (beg end)
"Check is there is fold mark in region BEG END."
(save-excursion
(goto-char beg)
(when (memq (folding-mark-look-at) '(1 11))
(goto-char end)
(memq (folding-mark-look-at) '(end end-in)))))
(defun folding-mark-look-at (&optional mode)
"Check status of current line. Does it contain a fold mark?.
MODE
'move move over fold mark
Return:
0 1 numberp, line has fold begin mark
0 = closed, 1 = open,
11 = open, we're inside fold, and this is top marker
'end end mark
'end-in end mark, inside fold, floor marker
nil no fold marks .."
(let* (case-fold-search
(marks (folding-get-mode-marks))
(stack folding-stack)
(bm (regexp-quote (nth 0 marks))) (em (concat "^[ \t\n]*" (regexp-quote (nth 1 marks))))
(bm-re (concat
(concat "^[ \t\n]*" bm)
(if (and nil
(string=
" " (substring (nth 0 marks)
(length (nth 1 marks)))))
"*"
"")))
ret
point)
(save-excursion
(beginning-of-line)
(cond
((looking-at bm-re)
(setq point (point))
(cond
((looking-at (concat "^[ \t\n]*" bm "[^\r\n]*\r")) (setq ret 0))
(t (goto-char (point-min))
(cond
((and stack (looking-at (concat "[ \t\n]*" bm)))
(setq ret 11))
(t
(setq ret 1))))))
((looking-at em)
(setq point (point))
(cond
((progn
(end-of-line)
(or (and stack (eobp)) (and stack (not (looking-at "\n[^ \t\n]*")))))
(setq ret 'end-in))
(t (setq ret 'end))))))
(cond
((and mode point)
(goto-char point)
(beginning-of-line)
(re-search-forward (concat bm "\\|" em))
(backward-char 1)))
ret))
(defsubst folding-mark-look-at-top-mark-p ()
"Check if line contain folding top marker."
(integerp (folding-mark-look-at)))
(defsubst folding-mark-look-at-bottom-mark-p ()
"Check if line contain folding bottom marker."
(symbolp (folding-mark-look-at)))
(defun folding-act (action &optional event)
"Execute logical ACTION based on EVENT.
References:
`folding-behave-table'"
(let* ((elt (assoc action folding-behave-table)))
(if elt
(funcall (nth 1 elt) event)
(error "Folding mode (folding-act): Unknown action %s" action))))
(defun folding-region-open-close (beg end &optional close)
"Open all folds inside region BEG END. Close if optional CLOSE is non-nil."
(interactive "r\nP")
(let* ((func (if (null close)
'folding-show-current-entry
'folding-hide-current-entry))
tmp)
(save-excursion
(if (> beg end) (setq tmp beg beg end end tmp))
(goto-char beg)
(while (and
(if (and close
(eq 0 (folding-mark-look-at))) t
(funcall func)
(end-of-line)
t)
(folding-next-visible-heading)
(< (point) end))))))
(defun fold-marks-kill ()
"If over fold, open fold and kill beginning and end fold marker.
Return t ot nil if marks were removed."
(interactive)
(if (not (folding-mark-look-at))
(when (called-interactively-p 'interactive)
(message "Folding: Cursor not over fold. Can't remove fold marks.")
nil)
(destructuring-bind (beg end)
(folding-show-current-entry)
(let ((kill-whole-line t))
(goto-char end)
(beginning-of-line)
(kill-line)
(goto-char beg)
(beginning-of-line)
(kill-line)
t))))
(defun folding-hide-current-subtree ()
"Call `folding-show-current-subtree' with argument 'hide."
(interactive)
(folding-show-current-subtree 'hide))
(defun folding-show-current-subtree (&optional hide)
"Show or HIDE all folds inside current fold.
Point must be over beginning fold mark."
(interactive "P")
(let* ((stat (folding-mark-look-at 'move))
(beg (point))
end)
(cond
((memq stat '(0 1 11)) (when (eq 0 stat) (folding-show-current-entry)
(goto-char beg)) (save-excursion
(if (folding-pick-move)
(setq end (point))))
(if (and beg end)
(folding-region-open-close beg end hide)))
(t
(if (called-interactively-p 'interactive)
(message "point is not at fold beginning."))))))
(defun folding-display-name ()
"Show current active fold name."
(interactive)
(let* ((pos (folding-find-folding-mark))
name)
(when pos
(save-excursion
(goto-char pos)
(if (looking-at ".*[{]+") (setq pos (match-end 0)))
(setq name (buffer-substring
pos
(progn
(end-of-line)
(point))))))
(if name
(message (format "fold:%s" name)))))
(defun folding-event-posn (act event)
"According to ACT read mouse EVENT struct and return data from it.
Event must be simple click, no dragging.
ACT
'mouse-point return the 'mouse cursor' point
'window return window pointer
'col-row return list (col row)"
(cond
((not folding-xemacs-p)
(let* ((el (funcall (symbol-function 'event-start) event)))
(cond
((eq act 'mouse-point)
(nth 1 el)) ((eq act 'window)
(funcall (symbol-function 'posn-window) el))
((eq act 'col-row)
(funcall (symbol-function 'posn-col-row) el))
(t
(error "Unknown request %s" act)))))
(folding-xemacs-p
(cond
((eq act 'mouse-point)
(funcall (symbol-function 'event-point) event))
((eq act 'window)
(funcall (symbol-function 'event-window) event))
((eq act 'col-row)
(list (funcall (symbol-function 'event-x) event)
(funcall (symbol-function 'event-y) event)))
(t
(error "Unknown request %s" act))))
(t
(error "This version of Emacs can't handle events."))))
(defmacro folding-interactive-spec-p ()
"Preserve region during `interactive'.
In XEmacs user could also set `zmacs-region-stays'."
(if folding-xemacs-p
`'(interactive "_p")
`'(interactive "p")))
(defmacro folding-mouse-yank-at-p ()
"Check if user use \"yank at mouse point\" feature.
Please see the variable `folding-mouse-yank-at-point'."
'folding-mouse-yank-at-point)
(defun folding-mouse-point (&optional event)
"Return mouse's working point. Optional EVENT is mouse click.
When used on XEmacs, return nil if no character was under the mouse."
(if (or (folding-mouse-yank-at-p)
(null event))
(point)
(folding-event-posn 'mouse-point event)))
(defmacro folding-find-file-hook ()
"Return hook symbol for current version."
`(if (boundp 'find-file-hook)
'find-file-hook
'find-file-hooks))
(defmacro folding-write-file-hook ()
"Return hook symbol for current version."
`(if (boundp 'write-file-functions)
'write-file-functions
'write-file-hooks))
(defun folding-is-hooked ()
"Check if folding hooks are installed."
(and (memq 'folding-mode-write-file
(symbol-value (folding-write-file-hook)))
(memq 'folding-mode-find-file
(symbol-value (folding-find-file-hook)))))
(defun folding-uninstall-hooks ()
"Remove hooks set by folding."
(turn-off-folding-mode)
(remove-hook 'finder-mode-hook 'folding-mode)
(remove-hook 'write-file-hooks 'folding-mode-write-file)
(remove-hook 'find-file-hooks 'folding-mode-find-file))
(defun folding-install-hooks ()
"Install folding hooks."
(folding-mode-add-find-file-hook)
(add-hook 'finder-mode-hook 'folding-mode)
(or (memq 'folding-mode-write-file (symbol-value (folding-write-file-hook)))
(add-hook (folding-write-file-hook) 'folding-mode-write-file 'end)))
(defun folding-keep-hooked ()
"Make sure hooks are in their places."
(unless (folding-is-hooked)
(folding-uninstall-hooks)
(folding-install-hooks)))
(defun folding-mouse-call-original (&optional event)
"Execute original mouse function using mouse EVENT.
Do nothing if original function does not exist.
Does nothing when called by a function which has earlier been called
by us.
Sets global:
`folding-calling-original'"
(interactive "@e") (if folding-calling-original
nil
(setq folding-calling-original t)
(unwind-protect
(progn
(or event
(setq event last-input-event))
(let (mouse-key)
(cond
((not folding-xemacs-p)
(setq mouse-key (make-vector 1 (car-safe event))))
(folding-xemacs-p
(setq mouse-key
(vector
(append
(event-modifiers event)
(list (intern
(format "button%d"
(funcall
(symbol-function 'event-button)
event))))))))
(t
(error "This version of Emacs can't handle events.")))
(let* ((folding-mode nil)
(orig-buf (current-buffer))
(orig-func (key-binding mouse-key)))
(when orig-func
(unwind-protect
(progn
(setq this-command orig-func)
(call-interactively orig-func))
(set-buffer orig-buf))))))
(setq folding-calling-original nil))))
(defun folding-mouse-context-sensitive (event)
"Perform some operation depending on the context of the mouse pointer.
EVENT is mouse event.
The variable `folding-behave-table' contains a mapping between contexts and
operations to perform.
The following contexts can be handled (They are named after the
natural operation to perform on them):
open - A folded fold.
close - An open fold, which isn't the one current topmost one.
up - The topmost visible fold.
other - Anything else.
Note that the `pointer' can be either the buffer point, or the mouse
pointer depending in the setting of the user option
`folding-mouse-yank-at-point'."
(interactive "e")
(let* ( (point (folding-mouse-point event))
state)
(if (null point)
(folding-act 'other event)
(save-excursion
(goto-char point)
(setq state (folding-mark-look-at)))
(cond
((eq state 0)
(folding-act 'open event))
((eq state 1)
(folding-act 'close event))
((eq state 11)
(folding-act 'up event))
((eq 'end state)
(folding-act 'close))
((eq state 'end-in)
(folding-act 'up event))
(t
(folding-act 'other event))))))
(defun folding-mouse-move (event)
"Move down if sitting on fold mark using mouse EVENT.
Original function behind the mouse is called if no FOLD action wasn't
taken."
(interactive "e")
(let* ( (point (folding-mouse-point event))
state)
(save-excursion
(goto-char point)
(beginning-of-line)
(setq state (folding-mark-look-at)))
(cond
((not (null state))
(goto-char point)
(folding-next-visible-heading) t)
(t
(folding-mouse-call-original event)))))
(defun folding-mouse-pick-move (event)
"Pick movement if sitting on beg/end fold mark using mouse EVENT.
If mouse if at the `beginning-of-line' point, then always move up.
Original function behind the mouse is called if no FOLD action wasn't
taken."
(interactive "e")
(let* ( (point (folding-mouse-point event))
state)
(save-excursion
(goto-char point)
(setq state (folding-mark-look-at)))
(cond
((not (null state))
(goto-char point)
(if (= point
(save-excursion (beginning-of-line) (point)))
(folding-previous-visible-heading)
(folding-pick-move)))
(t
(folding-mouse-call-original event)))))
(defun folding-set-mode-line ()
"Update modeline with fold level."
(if (null folding-stack)
(kill-local-variable 'folding-mode-string)
(make-local-variable 'folding-mode-string)
(setq folding-mode-string
(if (eq 'folded (car folding-stack))
(concat
folding-inside-string "1" folding-inside-mode-name)
(concat
folding-inside-string
(int-to-string (length folding-stack))
folding-inside-mode-name)))))
(defun folding-clear-stack ()
"Clear the fold stack, and release all the markers it refers to."
(let ((stack folding-stack))
(setq folding-stack nil)
(while (and stack (not (eq 'folded (car stack))))
(set-marker (car (car stack)) nil)
(set-marker (cdr (car stack)) nil)
(setq stack (cdr stack)))))
(defun folding-check-if-folding-allowed ()
"Return non-nil when buffer allowed to be folded automatically.
When buffer is loaded it may not be desirable to fold it immediately,
because the file may be too large, or it may contain fold marks, that
really are not _real_ folds. (Eg. RMAIL saved files may have the
marks)
This function returns t, if it's okay to proceed checking the fold status
of file. Returning nil means that folding should not touch this file.
The variable `folding-check-allow-folding-function' normally contains this
function. Change the variable to use your own scheme."
(or (let ((file (get 'find-file-noselect 'folding)))
(and file
(not (string-match (regexp-quote file)
(or buffer-file-name "")))))
(null (string-match folding-mode-hook-no-regexp (buffer-name)))))
(defun folding-mode-find-file ()
"One of the funcs called whenever a `find-file' is successful.
It checks to see if `folded-file' has been set as a buffer-local
variable, and automatically starts Folding mode if it has.
This allows folded files to be automatically folded when opened.
To make this hook effective, the symbol `folding-mode-find-file-hook'
should be placed at the end of `find-file-hooks'. If you have
some other hook in the list, for example a hook to automatically
uncompress or decrypt a buffer, it should go earlier on in the list.
See also `folding-mode-add-find-file-hook'."
(let* ((check-fold folding-check-folded-file-function)
(allow-fold folding-check-allow-folding-function))
(if (funcall allow-fold)
(or (and (and check-fold (funcall check-fold))
(folding-mode 1))
(and (assq 'folded-file (buffer-local-variables))
folded-file
(folding-mode 1)
(kill-local-variable 'folded-file)))
(if folding-mode
(folding-mode -1)))))
(defun folding-mode-add-find-file-hook ()
"Append `folding-mode-find-file-hook' to the list `find-file-hooks'.
This has the effect that afterwards, when a folded file is visited, if
appropriate Emacs local variable entries are recognized at the end of
the file, Folding mode is started automatically.
If `inhibit-local-variables' is non-nil, this will not happen regardless
of the setting of `find-file-hooks'.
To declare a file to be folded, put `folded-file: t' in the file's
local variables. eg., at the end of a C source file, put:
/*
Local variables:
folded-file: t
*/
The local variables can be inside a fold."
(interactive)
(or (memq 'folding-mode-find-file (symbol-value (folding-find-file-hook)))
(add-hook (folding-find-file-hook) 'folding-mode-find-file 'end)))
(defun folding-mode-write-file ()
"Folded files must be controlled by folding before saving.
This function turns on the folding mode if it is not activated.
It prevents 'binary pollution' upon save."
(let* ((check-func folding-check-folded-file-function)
(no-re folding-mode-hook-no-regexp)
(bn (or (buffer-name) "")))
(if (and (not (string-match no-re bn))
(boundp 'folding-mode)
(null folding-mode)
(and check-func (funcall check-func)))
(progn
(folding-mode 1)))
nil))
(defun folding-check-folded ()
"Function to determine if this file is in folded form."
(let* ( (folding-re1 "^.?.?.?{{{")
(folding-re2 "[\r\n].*}}}"))
(save-excursion
(goto-char (point-min))
(and (re-search-forward folding-re1 nil t)
(search-forward "\r" nil t)
(re-search-forward folding-re2 nil t)))))
(defun folding-font-lock-keywords (&optional mode)
"Return folding font-lock keywords for MODE."
(destructuring-bind (beg end ignore)
(folding-get-mode-marks (or mode major-mode))
(or ignore
(setq ignore t))
(setq beg (concat "^[ \t]*" (regexp-quote beg) "[^\r\n]+"))
(setq end (concat "^[ \t]*" (regexp-quote end)))
(list
(list beg 0 folding-font-lock-begin-mark t)
(list end 0 folding-font-lock-end-mark t))))
(defun folding-font-lock-support-instantiate (&optional mode)
"Add fold marks with `font-lock-add-keywords'."
(or mode
(setq mode major-mode))
(let ((function 'font-lock-add-keywords))
(when (fboundp function)
(funcall function
mode
(folding-font-lock-keywords mode))
(dolist (buffer (buffer-list))
(with-current-buffer buffer
(when (and (eq major-mode mode)
(or font-lock-mode
(and (boundp 'global-font-lock-mode)
global-font-lock-mode)))
(font-lock-mode -1)
(font-lock-mode 1)))))))
(defun folding-font-lock-support ()
"Add font lock support."
(let ((list (get 'folding-mode 'font-lock)))
(unless (memq major-mode list)
(push major-mode list)
(put 'folding-mode 'font-lock list)
(folding-font-lock-support-instantiate major-mode))))
(defun folding-set-local-variables ()
"Set local fold mark variables.
If you're going to change the beginning and end mark in
`folding-mode-marks-alist'; you must call this function."
(set (make-local-variable 'folding-stack) nil)
(make-local-variable 'folding-top-mark)
(make-local-variable 'folding-secondary-top-mark)
(make-local-variable 'folding-top-regexp)
(make-local-variable 'folding-bottom-mark)
(make-local-variable 'folding-bottom-regexp)
(make-local-variable 'folding-regexp)
(or (and (boundp 'folding-top-regexp)
folding-top-regexp
(boundp 'folding-bottom-regexp)
folding-bottom-regexp)
(let ((folding-marks (assq major-mode
folding-mode-marks-alist)))
(if folding-marks
(setq folding-marks (cdr folding-marks))
(setq folding-marks '("{{{" "}}}")))
(apply 'folding-set-marks folding-marks))))
(defun turn-off-folding-mode ()
"Turn off folding."
(interactive)
(folding-mode -1))
(defun turn-on-folding-mode ()
"Turn on folding."
(interactive)
(folding-mode 1))
(defun folding-mode (&optional arg inter)
"A folding-editor-like minor mode. ARG INTER.
These are the basic commands that Folding mode provides:
\\{folding-mode-map}
Keys starting with `folding-mode-prefix-key'
\\{folding-mode-prefix-map}
folding-convert-buffer-for-printing:
`\\[folding-convert-buffer-for-printing]'
Makes a ready-to-print, formatted, unfolded copy in another buffer.
Read the documentation for the above functions for more information.
Overview
Folds are a way of hierarchically organizing the text in a file, so
that the text can be viewed and edited at different levels. It is
similar to Outline mode in that parts of the text can be hidden from
view. A fold is a region of text, surrounded by special \"fold marks\",
which act like brackets, grouping the text. Fold mark pairs can be
nested, and they can have titles. When a fold is folded, the text is
hidden from view, except for the first line, which acts like a title
for the fold.
Folding mode is a minor mode, designed to cooperate with many other
major modes, so that many types of text can be folded while they are
being edited (eg., plain text, program source code, Texinfo, etc.).
Folding-mode function
If Folding mode is not called interactively (`(called-interactively-p 'interactive)' is nil),
and it is called with two or less arguments, all of which are nil, then
the point will not be altered if `folding-folding-on-startup' is set
and `folding-whole-buffer' is called. This is generally not a good
thing, as it can leave the point inside a hidden region of a fold, but
it is required if the local variables set \"mode: folding\" when the
file is first read (see `hack-local-variables').
Not that you should ever want to, but to call Folding mode from a
program with the default behavior (toggling the mode), call it with
something like `(folding-mode nil t)'.
Fold marks
For most types of folded file, lines representing folds have \"{{{\"
near the beginning. To enter a fold, move the point to the folded line
and type `\\[folding-shift-in]'. You should no longer be able to see
the rest of the file, just the contents of the fold, which you couldn't
see before. You can use `\\[folding-shift-out]' to leave a fold, and
you can enter and exit folds to move around the structure of the file.
All of the text is present in a folded file all of the time. It is just
hidden. Folded text shows up as a line (the top fold mark) with \"...\"
at the end. If you are in a fold, the mode line displays \"inside n
folds Narrow\", and because the buffer is narrowed you can't see outside
of the current fold's text.
By arranging sections of a large file in folds, and maybe subsections
in sub-folds, you can move around a file quickly and easily, and only
have to scroll through a couple of pages at a time. If you pick the
titles for the folds carefully, they can be a useful form of
documentation, and make moving though the file a lot easier. In
general, searching through a folded file for a particular item is much
easier than without folds.
Managing folds
To make a new fold, set the mark at one end of the text you want in the
new fold, and move the point to the other end. Then type
`\\[folding-fold-region]'. The text you selected will be made into a
fold, and the fold will be entered. If you just want a new, empty fold,
set the mark where you want the fold, and then create a new fold there
without moving the point. Don't worry if the point is in the middle of
a line of text, `folding-fold-region' will not break text in the middle
of a line. After making a fold, the fold is entered and the point is
positioned ready to enter a title for the fold. Do not delete the fold
marks, which are usually something like \"{{{\" and \"}}}\". There may
also be a bit of fold mark which goes after the fold title.
If the fold markers get messed up, or you just want to see the whole
unfolded file, use `\\[folding-open-buffer]' to unfolded the whole
file, so you can see all the text and all the marks. This is useful for
checking/correcting unbalanced fold markers, and for searching for
things. Use `\\[folding-whole-file]' to fold the buffer again.
`folding-shift-out' will attempt to tidy the current fold just before
exiting it. It will remove any extra blank lines at the top and bottom,
\(outside the fold marks). It will then ensure that fold marks exists,
and if they are not, will add them (after asking). Finally, the number
of blank lines between the fold marks and the contents of the fold is
set to 1 (by default).
Folding package customizations
If the fold marks are not set on entry to Folding mode, they are set to
a default for current major mode, as defined by
`folding-mode-marks-alist' or to \"{{{ \" and \"}}}\" if none are
specified.
To bind different commands to keys in Folding mode, set the bindings in
the keymap `folding-mode-map'.
The hooks `folding-mode-hook' and `<major-mode-name>-folding-hook' are
called before folding the buffer and applying the key bindings in
`folding-mode-map'. This is a good hook to set extra or different key
bindings in `folding-mode-map'. Note that key bindings in
`folding-mode-map' are only examined just after calling these hooks;
new bindings in those maps only take effect when Folding mode is being
started. The hook `folding-load-hook' is called when Folding mode is
loaded into Emacs.
Mouse behavior
If you want folding to detect point of actual mouse click, please see
variable `folding-mouse-yank-at-p'.
To customise the mouse actions, look at `folding-behave-table'."
(interactive)
(let ((new-folding-mode
(if (not arg)
(not folding-mode)
(> (prefix-numeric-value arg) 0))))
(or (eq new-folding-mode
folding-mode)
(if folding-mode
(progn
(if (null (folding-use-overlays-p))
(setq selective-display nil))
(folding-clear-stack)
(folding-narrow-to-region nil nil)
(folding-subst-regions (list 1 (point-max)) ?\r ?\n)
(setq mode-line-format
(mapcar
(function
(lambda (item)
(if (equal item 'folding-narrow-placeholder)
"%n" item)))
mode-line-format)))
(cond
((folding-use-overlays-p)
(make-local-variable 'line-move-ignore-invisible)
(setq line-move-ignore-invisible t
buffer-invisibility-spec '((t . t))))
(t
(setq selective-display t)
(setq selective-display-ellipses t)))
(unless (assq 'folding-mode minor-mode-alist)
(folding-install))
(folding-keep-hooked) (widen)
(setq folding-narrow-overlays nil)
(folding-set-local-variables)
(folding-font-lock-support)
(unwind-protect
(let ((hook-symbol (intern-soft
(concat
(symbol-name major-mode)
"-folding-hook"))))
(run-hooks 'folding-mode-hook)
(and hook-symbol
(run-hooks hook-symbol)))
(folding-set-mode-line))
(and folding-folding-on-startup
(if (or (called-interactively-p 'interactive)
arg
inter)
(folding-whole-buffer)
(save-excursion
(folding-whole-buffer))))
(folding-narrow-to-region nil nil t)
(setq mode-line-format
(mapcar
(function
(lambda (item)
(if (equal item "%n")
'folding-narrow-placeholder item)))
mode-line-format))))
(setq folding-mode new-folding-mode)
(if folding-mode
(easy-menu-add folding-mode-menu)
(easy-menu-remove folding-mode-menu))))
(defun folding-set-marks (top bottom &optional secondary)
"Set the folding top and bottom mark for the current buffer.
Input:
TOP The topmost fold mark. Comment start + fold begin string.
BOTTOM The bottom fold mark Comment end + fold end string.
SECONDARY Usually the comment end indicator for the mode. This
is inserted by `folding-fold-region' after the fold top mark,
and is presumed to be put after the title of the fold.
Example:
html-mode:
top: \"<!-- [[[ \"
bot: \"<!-- ]]] -->\"
sec: \" -->\"
Notice that the top marker needs to be closed with SECONDARY comment end string.
Various regular expressions are set with this function, so don't set the
mark variables directly."
(set (make-local-variable 'folding-top-mark)
top)
(set (make-local-variable 'folding-bottom-mark)
bottom)
(set (make-local-variable 'folding-secondary-top-mark)
secondary)
(set (make-local-variable 'folding-top-regexp)
(concat "\\(^\\|\r+\\)[ \t]*"
(regexp-quote folding-top-mark)))
(set (make-local-variable 'folding-bottom-regexp)
(concat "\\(^\\|\r+\\)[ \t]*"
(regexp-quote folding-bottom-mark)))
(set (make-local-variable 'folding-regexp)
(concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\("
(regexp-quote folding-top-mark)
"\\)\\|\\("
(regexp-quote folding-bottom-mark)
"[ \t]*\\(\\)\\($\\|\r\\)\\)\\)")))
(defun folding-next-visible-heading (&optional direction)
"Move up/down fold headers.
Backward if DIRECTION is non-nil returns nil if not moved = no next marker."
(interactive)
(let* ((begin-mark (nth 0 (folding-get-mode-marks)))
case-fold-search)
(if direction
(re-search-backward (concat "^" (regexp-quote begin-mark)) nil t)
(re-search-forward (concat "^" (regexp-quote begin-mark)) nil t))))
(defun folding-previous-visible-heading ()
"Move upward fold headers."
(interactive)
(beginning-of-line)
(folding-next-visible-heading 'backward))
(defun folding-find-folding-mark (&optional end-fold)
"Search backward to find beginning fold. Skips subfolds.
Optionally searches forward to find END-FOLD mark.
Return:
nil
point position of fold mark"
(let* (case-fold-search
(elt (folding-get-mode-marks))
(bm (regexp-quote (nth 0 elt))) (em (regexp-quote (nth 1 elt))) (re (concat "^" bm "\\|^" em))
(count 0)
stat
moved)
(save-excursion
(cond
(end-fold
(folding-end-of-line)
(while (and (null moved)
(re-search-forward re nil t))
(setq stat (folding-mark-look-at))
(cond
((symbolp stat)
(setq count (1- count))
(if (< count 0) (setq moved t)))
((memq stat '(1 11)) (setq count (1+ count))))) (when moved
(forward-char -3)
(setq moved (point))))
(t
(while (and (null moved)
(re-search-backward re nil t))
(setq stat (folding-mark-look-at))
(cond
((memq stat '(1 11))
(setq count (1- count))
(if (< count 0) (setq moved (point))))
((symbolp stat)
(setq count (1+ count)))))
(when moved (forward-char 3)
(setq moved (point))))))
moved))
(defun folding-pick-move ()
"Pick the logical movement on fold mark.
If at the end of fold, then move to the beginning and vice versa.
If placed over closed fold moves to the next fold. When no next
folds are visible, stops moving.
Return:
t if moved"
(interactive)
(let* (case-fold-search
(elt (folding-get-mode-marks))
(bm (nth 0 elt)) (stat (folding-mark-look-at))
moved)
(cond
((eq 0 stat) (when (re-search-forward (concat "^" (regexp-quote bm)) nil t)
(setq moved t)
(forward-char 3)))
((symbolp stat) (setq moved (folding-find-folding-mark)))
((integerp stat) (setq moved (folding-find-folding-mark 'end-fold))))
(if (integerp moved)
(goto-char moved))
moved))
(defun folding-context-next-action ()
"Take next action according to point and context.
If point is at:
Begin Fold : toggle open - close
End Fold : close
inside : fold current level."
(interactive)
(let ((state (folding-mark-look-at)))
(cond
((eq state 0)
(folding-act 'open))
((eq state 1)
(folding-act 'close))
((eq state 11)
(folding-act 'up))
((eq 'end state)
(folding-act 'close))
((eq state 'end-in)
(folding-act 'up))
(t
(folding-act 'other)))))
(defun folding-forward-char-1 (&optional arg)
"See `folding-forward-char-1' for ARG."
(if (eq arg 1)
(if (eq (following-char) ?\r)
(let ((saved (point))
(inhibit-quit t))
(end-of-line)
(if (not (eobp))
(forward-char)
(goto-char saved)
(error "End of buffer")))
(forward-char))
(if (> 0 (or arg (setq arg 1)))
(folding-backward-char (- arg))
(let (goal saved)
(while (< 0 arg)
(skip-chars-forward "^\r" (setq goal (+ (point) arg)))
(if (eq goal (point))
(setq arg 0)
(if (eobp)
(error "End of buffer")
(setq arg (- goal 1 (point))
saved (point))
(let ((inhibit-quit t))
(end-of-line)
(if (not (eobp))
(forward-char)
(goto-char saved)
(error "End of buffer"))))))))))
(defmacro folding-forward-char-macro ()
`(defun folding-forward-char (&optional arg)
"Move point right ARG characters, skipping hidden folded regions.
Moves left if ARG is negative. On reaching end of buffer, stop and
signal error."
,(folding-interactive-spec-p)
(folding-forward-char-1 arg)))
(folding-forward-char-macro)
(defun folding-backward-char-1 (&optional arg)
"See `folding-backward-char-1' for ARG."
(if (eq arg 1)
(if (or (eq (preceding-char) ?\n)
(eq (preceding-char) ?\r))
(let ((pos (1- (point)))
(inhibit-quit t))
(forward-char -1)
(beginning-of-line)
(skip-chars-forward "^\r" pos))
(forward-char -1))
(if (> 0 (or arg (setq arg 1)))
(folding-forward-char (- arg))
(let (goal)
(while (< 0 arg)
(skip-chars-backward "^\r\n" (max (point-min)
(setq goal (- (point) arg))))
(if (eq goal (point))
(setq arg 0)
(if (bobp)
(error "Beginning of buffer")
(setq arg (- (point) 1 goal)
goal (point))
(let ((inhibit-quit t))
(forward-char -1)
(beginning-of-line)
(skip-chars-forward "^\r" goal)))))))))
(defmacro folding-backward-char-macro ()
`(defun folding-backward-char (&optional arg)
"Move point right ARG characters, skipping hidden folded regions.
Moves left if ARG is negative. On reaching end of buffer, stop and
signal error."
,(folding-interactive-spec-p)
(folding-backward-char-1 arg)))
(folding-backward-char-macro)
(defmacro folding-end-of-line-macro ()
`(defun folding-end-of-line (&optional arg)
"Move point to end of current line, but before hidden folded region.
ARG is line count.
Has the same behavior as `end-of-line', except that if the current line
ends with some hidden folded text (represented by an ellipsis), the
point is positioned just before it. This prevents the point from being
placed inside the folded text, which is not normally useful."
,(folding-interactive-spec-p)
(if (or (eq arg 1)
(not arg))
(beginning-of-line)
(forward-line (1- arg)))
(skip-chars-forward "^\r\n")))
(folding-end-of-line-macro)
(defun folding-skip-ellipsis-backward ()
"Move the point backwards out of folded text.
If the point is inside a folded region, the cursor is displayed at the
end of the ellipsis representing the folded part. This function checks
to see if this is the case, and if so, moves the point backwards until
it is just outside the hidden region, and just before the ellipsis.
Returns t if the point was moved, nil otherwise."
(interactive)
(let ((pos (point))
result)
(save-excursion
(beginning-of-line)
(skip-chars-forward "^\r" pos)
(or (eq pos (point))
(setq pos (point)
result t)))
(goto-char pos)
result))
(defun folding-shift-in (&optional noerror)
"Open and enter the fold at or around the point.
Enters the fold that the point is inside, wherever the point is inside
the fold, provided it is a valid fold with balanced top and bottom
marks. Returns nil if the fold entered contains no sub-folds, t
otherwise. If an optional argument NOERROR is non-nil, returns nil if
there are no folds to enter, instead of causing an error.
If the point is inside a folded, hidden region (as represented by an
ellipsis), the position of the point in the buffer is preserved, and as
many folds as necessary are entered to make the surrounding text
visible. This is useful after some commands eg., search commands."
(interactive)
(cl-labels
((open-fold nil
(let ((data (folding-show-current-entry noerror t)))
(and data
(progn
(when folding-narrow-by-default
(setq folding-stack
(if folding-stack
(cons (cons (point-min-marker)
(point-max-marker))
folding-stack)
'(folded)))
(folding-set-mode-line))
(folding-narrow-to-region
(car data)
(nth 1 data)))))))
(let ((goal (point)))
(while (folding-skip-ellipsis-backward)
(beginning-of-line)
(open-fold)
(goto-char goal))
(if folding-narrow-by-default
(open-fold)
(widen)))))
(defun folding-shift-out (&optional event)
"Exits the current fold with EVENT."
(interactive)
(if folding-stack
(progn
(folding-tidy-inside)
(cond
((folding-use-overlays-p)
(folding-subst-regions
(list (overlay-end (car folding-narrow-overlays))
(overlay-start (cdr folding-narrow-overlays))) ?\n ?\r)
(goto-char (overlay-end (car folding-narrow-overlays))))
(t
(folding-subst-regions (list (point-min) (point-max)) ?\n ?\r)
(goto-char (point-min))))
(if (eq (car folding-stack) 'folded)
(folding-narrow-to-region nil nil t)
(folding-narrow-to-region
(marker-position (car (car folding-stack)))
(marker-position (cdr (car folding-stack))) t))
(and (consp (car folding-stack))
(set-marker (car (car folding-stack)) nil)
(set-marker (cdr (car folding-stack)) nil))
(setq folding-stack (cdr folding-stack)))
(error "Outside all folds"))
(folding-set-mode-line))
(defun folding-show-current-entry (&optional event noerror noskip)
"Opens the fold that the point is on, but does not enter it.
EVENT and optional arg NOERROR means don't signal an error if there is
no fold, just return nil. NOSKIP means don't jump out of a hidden
region first.
Returns ((START END SUBFOLDS-P). START and END indicate the extents of
the fold that was shown. If SUBFOLDS-P is non-nil, the fold contains
subfolds."
(interactive)
(or noskip
(folding-skip-ellipsis-backward))
(let ((point (point))
backward
forward
start
end
subfolds-not-p)
(unwind-protect
(or (and (integerp
(car-safe (setq backward (folding-skip-folds t))))
(integerp
(car-safe (setq forward (folding-skip-folds nil))))
(progn
(goto-char (car forward))
(skip-chars-forward "^\r\n")
(setq end (point))
(skip-chars-forward "\r\n")
(not (and folding-stack (eobp))))
(progn
(goto-char (car backward))
(skip-chars-backward "^\r\n")
(setq start (point))
(skip-chars-backward "\r\n")
(not (and folding-stack (bobp))))
(progn
(setq point start)
(setq subfolds-not-p
(not (or (cdr backward)
(cdr forward))))
(folding-subst-regions
(append backward (nreverse forward))
?\r ?\n)
(if (or (and (boundp 'global-font-lock-mode)
global-font-lock-mode)
font-lock-mode)
(font-lock-fontify-region start end))
(list start end (not subfolds-not-p))))
(if noerror
nil
(error "Not on a fold")))
(goto-char point))))
(defun folding-toggle-enter-exit ()
"Run `folding-shift-in' or `folding-shift-out'.
This depends on current line's contents."
(interactive)
(beginning-of-line)
(let ((current-line-mark (folding-mark-look-at)))
(if (and (numberp current-line-mark)
(= current-line-mark 0))
(folding-shift-in)
(folding-shift-out))))
(defun folding-toggle-show-hide ()
"Run folding-show-current-entry or folding-hide-current-entry depending on current line's contents."
(interactive)
(beginning-of-line)
(let ((current-line-mark (folding-mark-look-at)))
(if (and (numberp current-line-mark)
(= current-line-mark 0))
(folding-show-current-entry)
(folding-hide-current-entry))))
(defun folding-hide-current-entry (&optional event)
"Close the fold around the point using EVENT.
Undo effect of `folding-show-current-entry'."
(interactive)
(folding-skip-ellipsis-backward)
(let (start end)
(if (and (integerp (setq start (car-safe (folding-skip-folds t))))
(integerp (setq end (car-safe (folding-skip-folds nil)))))
(if (and folding-stack
(or (eq start (point-min))
(eq end (point-max))))
(folding-shift-out)
(goto-char start)
(skip-chars-backward "^\r\n")
(folding-subst-regions (list start end) ?\n ?\r))
(error "Not on a fold"))))
(defun folding-show-all ()
"Exits all folds, to the top level."
(interactive)
(while folding-stack
(folding-shift-out)))
(defun folding-goto-line (line)
"Go to LINE, entering as many folds as possible."
(interactive "NGoto line: ")
(folding-show-all)
(goto-char 1)
(and (< 1 line)
(re-search-forward "[\n\C-m]" nil 0 (1- line)))
(let ((goal (point)))
(while (prog2 (beginning-of-line)
(folding-shift-in t)
(goto-char goal))))
(folding-narrow-to-region
(and folding-narrow-by-default (point-min))
(point-max) t))
(defun folding-skip-folds (backward &optional outside)
"Skips forward through the buffer (backward if BACKWARD is non-nil)
until it finds a closing fold mark or the end of the buffer. The
point is not moved. Jumps over balanced folding-mark pairs on the way.
Returns t if the end of buffer was found in an unmatched folding-mark
pair, otherwise a list.
If the point is actually on an fold start mark, the mark is ignored;
if it is on an end mark, the mark is noted. This decision is
reversed if BACKWARD is non-nil. If optional OUTSIDE is non-nil and
BACKWARD is nil, either mark is noted.
The first element of the list is a position in the end of the closing
fold mark if one was found, or nil. It is followed by (END START)
pairs (flattened, not a list of pairs). The pairs indicating the
positions of folds skipped over; they are positions in the fold
marks, not necessarily at the ends of the fold marks. They are in
the opposite order to that in which they were skipped. The point is
left in a meaningless place. If going backwards, the pairs are
\(START END) pairs, as the fold marks are scanned in the opposite
order.
Works by maintaining the position of the top and bottom marks found
so far. They are found separately using a normal string search for
the fixed part of a fold mark (because it is faster than a regexp
search if the string does not occur often outside of fold marks),
checking that it really is a proper fold mark, then considering the
earliest one found. The position of the other (if found) is
maintained to avoid an unnecessary search at the next iteration."
(let ((first-mark (if backward folding-bottom-mark folding-top-mark))
(last-mark (if backward folding-top-mark folding-bottom-mark))
(top-re folding-top-regexp)
(depth 0)
pairs point
temp
start
first
last
case-fold-search)
(when nil
(when (and (stringp first-mark)
(string-match "^\\(.*[^ ]+\\) +$" first-mark))
(setq first-mark (match-string 1 first-mark)))
(when (and (stringp last-mark)
(string-match "^\\(.*[^ ]+\\) +$" last-mark))
(setq last-mark (match-string 1 last-mark)))
(when (and (stringp top-re)
(string-match "^\\(.*[^ ]+\\) +$" top-re))
(setq top-re (match-string 1 top-re))))
(save-excursion
(skip-chars-backward "^\r\n")
(unless outside
(and (eq (preceding-char) ?\r)
(forward-char -1))
(if (looking-at top-re)
(if backward
(setq last (match-end 1))
(skip-chars-forward "^\r\n"))))
(while (progn
(setq point (point))
(or last
(while (and (if backward
(search-backward last-mark first t)
(search-forward last-mark first t))
(progn
(setq temp (point))
(goto-char (match-beginning 0))
(skip-chars-backward " \t")
(and (not
(setq last
(if (eq (preceding-char) ?\r)
temp
(and (bolp) temp))))
(goto-char temp)))))
(goto-char point))
(or first
(while (and (if backward
(search-backward first-mark last t)
(search-forward first-mark last t))
(progn
(setq temp (point))
(goto-char (match-beginning 0))
(skip-chars-backward " \t")
(and (not
(setq first
(if (eq (preceding-char) ?\r)
temp
(and (bolp) temp))))
(goto-char temp))))))
(if (not last)
(not (setq pairs (if first t (cons nil pairs))))
(if (and first
(if backward
(> first last)
(< first last)))
(progn
(goto-char first)
(if (eq 0 depth)
(setq start first
first nil
depth 1) (setq first nil
depth (1+ depth))))
(goto-char last)
(if (eq 0 depth)
(not (setq pairs (cons last pairs)))
(or (< 0 (setq depth (1- depth)))
(setq pairs (cons last (cons start pairs))))
(setq last nil)
t)))))
pairs)))
(defun folding-fold-region (start end)
"Places fold mark at the beginning and end of a specified region.
The region is specified by two arguments START and END. The point is
left at a suitable place ready to insert the title of the fold.
The fold markers are intended according to mode."
(interactive "r")
(and (< end start)
(setq start (prog1 end
(setq end start))))
(setq end (set-marker (make-marker) end))
(goto-char start)
(beginning-of-line)
(setq start (point))
(insert-before-markers folding-top-mark)
(unless (string-match "latex" (symbol-name major-mode))
(indent-according-to-mode))
(let ((saved-point (point)))
(and folding-secondary-top-mark
(insert-before-markers folding-secondary-top-mark))
(insert-before-markers ?\n)
(goto-char (marker-position end))
(set-marker end nil)
(and (not (bolp))
(eq 0 (forward-line))
(eobp)
(insert ?\n))
(insert folding-bottom-mark)
(unless (string-match "latex" (symbol-name major-mode))
(indent-according-to-mode))
(insert ?\n)
(setq folding-stack (if folding-stack
(cons (cons (point-min-marker)
(point-max-marker))
folding-stack)
'(folded)))
(folding-narrow-to-region start (1- (point)))
(goto-char saved-point)
(folding-set-mode-line))
(save-excursion (folding-tidy-inside)))
(defun folding-tidy-inside ()
"Add or remove blank lines at the top and bottom of the current fold.
Also adds fold marks at the top and bottom (after asking), if they are not
there already. The amount of space left depends on the variable
`folding-internal-margins', which is one by default."
(interactive)
(if buffer-read-only nil
(let ()
(if (folding-use-overlays-p)
(goto-char (- (overlay-end (car folding-narrow-overlays)) 1))
(goto-char (point-min)))
(and (eolp)
(progn (skip-chars-forward "\n\t ")
(delete-region (point-min) (point))))
(and (if (let (case-fold-search) (folding-mark-look-at-top-mark-p))
(progn (forward-line 1)
(and (eobp) (insert ?\n))
t)
(and (y-or-n-p "Insert missing folding-top-mark? ")
(progn (insert (concat folding-top-mark
"<Replaced missing fold top mark>"
(or folding-secondary-top-mark "")
"\n"))
t)))
folding-internal-margins
(<= 0 folding-internal-margins)
(let* ((p1 (point))
(p2 (progn (skip-chars-forward "\n") (point)))
(p3 (progn (skip-chars-forward "\n\t ")
(skip-chars-backward "\t " p2) (point))))
(if (eq p2 p3)
(or (eq p2 (setq p3 (+ p1 folding-internal-margins)))
(if (< p2 p3)
(newline (- p3 p2))
(delete-region p3 p2)))
(delete-region p1 p3)
(or (eq 0 folding-internal-margins)
(newline folding-internal-margins)))))
(if (folding-use-overlays-p)
(goto-char (overlay-start (cdr folding-narrow-overlays)))
(goto-char (point-max)))
(and (bolp)
(progn (skip-chars-backward "\n")
(delete-region (point) (point-max))))
(beginning-of-line)
(and (or (let (case-fold-search) (folding-mark-look-at-bottom-mark-p))
(progn (goto-char (point-max)) nil)
(and (y-or-n-p "Insert missing folding-bottom-mark? ")
(progn
(insert (concat "\n" folding-bottom-mark))
(beginning-of-line)
t)))
folding-internal-margins
(<= 0 folding-internal-margins)
(let* ((p1 (point))
(p2 (progn (skip-chars-backward "\n") (point)))
(p3 (progn (skip-chars-backward "\n\t ")
(skip-chars-forward "\t " p2) (point))))
(if (eq p2 p3)
(or (eq p2 (setq p3 (- p1 1 folding-internal-margins)))
(if (> p2 p3)
(newline (- p2 p3))
(delete-region p2 p3)))
(delete-region p3 p1)
(newline (1+ folding-internal-margins))))))))
(defun folding-whole-buffer ()
"Folds every fold in the current buffer.
Fails if the fold markers are not balanced correctly.
If the buffer is being viewed in a fold, folds are repeatedly exited to
get to the top level first (this allows the folds to be tidied on the
way out). The buffer modification flag is not affected, and this
function will work on read-only buffers."
(interactive)
(message "Folding buffer...")
(let ((narrow-min (point-min))
(narrow-max (point-max))
folding-list)
(save-excursion
(widen)
(goto-char 1)
(setq folding-list (folding-skip-folds nil t))
(narrow-to-region narrow-min narrow-max)
(and (eq t folding-list)
(error
"Cannot fold whole buffer -- unmatched begin-fold mark `%s' `%s'"
(current-buffer)
folding-top-mark))
(and (integerp (car folding-list))
(error
"Cannot fold whole buffer -- extraneous end-fold mark `%s' `%s'"
(current-buffer)
folding-bottom-mark))
(folding-show-all)
(widen)
(goto-char 1)
(folding-subst-regions (nreverse (cdr folding-list)) ?\n ?\r))
(beginning-of-line)
(folding-narrow-to-region nil nil t)
(message "Folding buffer... done")))
(defun folding-open-buffer ()
"Unfolds the entire buffer, leaving the point where it is.
Does not affect the buffer-modified flag, and can be used on read-only
buffers."
(interactive)
(message "Unfolding buffer...")
(folding-clear-stack)
(folding-set-mode-line)
(unwind-protect
(progn
(widen)
(folding-subst-regions (list 1 (point-max)) ?\r ?\n))
(folding-narrow-to-region nil nil t))
(message "Unfolding buffer... done"))
(defun folding-convert-buffer-for-printing (&optional buffer pre-title post-title pad)
"Remove folds from a buffer, for printing.
It copies the contents of the (hopefully) folded buffer BUFFER into a
buffer called `*Unfolded: <Original-name>*', removing all of the fold
marks. It keeps the titles of the folds, however, and numbers them.
Subfolds are numbered in the form 5.1, 5.2, 5.3 etc., and the titles are
indented to eleven characters.
It accepts four arguments. BUFFER is the name of the buffer to be
operated on, or a buffer. nil means use the current buffer. PRE-TITLE
is the text to go before the replacement fold titles, POST-TITLE is the
text to go afterwards. Finally, if PAD is non-nil, the titles are all
indented to the same column, which is eleven plus the length of
PRE-TITLE. Otherwise just one space is placed between the number and
the title."
(interactive (list (read-buffer "Remove folds from buffer: "
(buffer-name)
t)
(read-string "String to go before enumerated titles: ")
(read-string "String to go after enumerated titles: ")
(y-or-n-p "Pad section numbers with spaces? ")))
(set-buffer (setq buffer (get-buffer buffer)))
(setq pre-title (or pre-title "")
post-title (or post-title ""))
(or folding-mode
(error "Must be in Folding mode before removing folds"))
(let* ((new-buffer (get-buffer-create (concat "*Unfolded: "
(buffer-name buffer)
"*")))
(section-list '(1))
(section-prefix-list '(""))
(secondary-mark-length (length folding-secondary-top-mark))
(secondary-mark folding-secondary-top-mark)
(mode major-mode)
(regexp
(concat "\\(^\\|\r\\)\\([ \t]*\\)\\(\\("
(regexp-quote folding-top-mark)
"\\)\\|\\("
(regexp-quote folding-bottom-mark)
"[ \t]*.*\\(\\)\\($\\|\r\\)\\)\\)"))
title
prefix)
(buffer-disable-undo new-buffer)
(save-excursion
(set-buffer new-buffer)
(delete-region (point-min)
(point-max)))
(save-restriction
(widen)
(copy-to-buffer new-buffer (point-min) (point-max)))
(display-buffer new-buffer t)
(set-buffer new-buffer)
(subst-char-in-region (point-min) (point-max) ?\r ?\n)
(funcall mode)
(while (re-search-forward regexp nil t)
(if (match-beginning 4)
(progn
(goto-char (match-end 4))
(setq title
(buffer-substring (point)
(progn (end-of-line)
(point))))
(delete-region (save-excursion
(goto-char (match-beginning 4))
(skip-chars-backward "\n\r")
(point))
(progn
(skip-chars-forward "\n\r")
(point)))
(and (<= secondary-mark-length
(length title))
(string-equal secondary-mark
(substring title
(- secondary-mark-length)))
(setq title (substring title
0
(- secondary-mark-length))))
(setq section-prefix-list
(cons (setq prefix (concat (car section-prefix-list)
(int-to-string (car section-list))
"."))
section-prefix-list))
(or (cdr section-list)
(insert ?\n))
(setq section-list (cons 1
(cons (1+ (car section-list))
(cdr section-list))))
(setq title (concat prefix
(if pad
(make-string
(max 2 (- 8 (length prefix))) ? )
" ")
title))
(message "Reformatting: %s%s%s"
pre-title
title
post-title)
(insert "\n\n"
pre-title
title
post-title
"\n\n"))
(goto-char (match-beginning 5))
(or (setq section-list (cdr section-list))
(error "Too many bottom-of-fold marks"))
(setq section-prefix-list (cdr section-prefix-list))
(delete-region (point)
(progn
(forward-line 1)
(point)))))
(and (cdr section-list)
(error
"Too many top-of-fold marks -- reached end of file prematurely"))
(goto-char (point-min))
(buffer-enable-undo)
(set-buffer-modified-p nil)
(message "All folds reformatted.")))
(defun folding-add-to-marks-list (mode top bottom
&optional secondary noforce message)
"Add/set fold mark list for a particular major mode.
When called interactively, asks for a `major-mode' name, and for
fold marks to be used in that mode. It adds the new set to
`folding-mode-marks-alist', and if the mode name is the same as the current
major mode for the current buffer, the marks in use are also changed.
If called non-interactively, arguments are MODE, TOP, BOTTOM and
SECONDARY. MODE is the symbol for the major mode for which marks are
being set. TOP, BOTTOM and SECONDARY are strings, the three fold marks
to be used. SECONDARY may be nil (as opposed to the empty string), but
the other two must be non-empty strings, and is an optional argument.
Two other optional arguments are NOFORCE, meaning do not change the
marks if marks are already set for the specified mode if non-nil, and
MESSAGE, which causes a message to be displayed if it is non-nil. This
is also the message displayed if the function is called interactively.
To set default fold marks for a particular mode, put something like the
following in your .emacs:
\(folding-add-to-marks-list 'major-mode \"(** {{{ \" \"(** }}} **)\" \" **)\")
Look at the variable `folding-mode-marks-alist' to see what default settings
already apply.
`folding-set-marks' can be used to set the fold marks in use in the current
buffer without affecting the default value for a particular mode."
(interactive
(let* ((mode (completing-read
(concat "Add fold marks for major mode ("
(symbol-name major-mode)
"): ")
obarray
(function
(lambda (arg)
(and (commandp arg)
(string-match "-mode\\'"
(symbol-name arg)))))
t))
(mode (if (equal mode "")
major-mode
(intern mode)))
(object (assq mode folding-mode-marks-alist))
(old-top (and object
(nth 1 object)))
top
(old-bottom (and object
(nth 2 object)))
bottom
(secondary (and object
(nth 3 object)))
(prompt "Top fold marker: "))
(and (equal secondary "")
(setq secondary nil))
(while (not top)
(setq top (read-string prompt (or old-top "{{{ ")))
(and (equal top "")
(setq top nil)))
(setq prompt (concat prompt
top
", Bottom marker: "))
(while (not bottom)
(setq bottom (read-string prompt (or old-bottom "}}}")))
(and (equal bottom "")
(setq bottom nil)))
(setq prompt (concat prompt
bottom
(if secondary
", Secondary marker: "
", Secondary marker (none): "))
secondary (read-string prompt secondary))
(and (equal secondary "")
(setq secondary nil))
(list mode top bottom secondary nil t)))
(let ((object (assq mode folding-mode-marks-alist)))
(if (and object
noforce
message)
(message "Fold markers for `%s' are already set."
(symbol-name mode))
(if object
(or noforce
(setcdr object (if secondary
(list top bottom secondary)
(list top bottom))))
(setq folding-mode-marks-alist
(cons (if secondary
(list mode top bottom secondary)
(list mode top bottom))
folding-mode-marks-alist)))
(and message
(message "Set fold marks for `%s' to \"%s\" and \"%s\"."
(symbol-name mode)
(if secondary
(concat top "name" secondary)
(concat top "name"))
bottom)
(and (eq major-mode mode)
(folding-set-marks top bottom secondary))))))
(folding-add-to-marks-list 'ada-mode "-- {{{" "-- }}}" nil t)
(folding-add-to-marks-list 'asm-mode "; {{{" "; }}}" nil t)
(folding-add-to-marks-list 'awk-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'Bison-mode "/* {{{" "/* }}} */" " */" t)
(folding-add-to-marks-list 'LaTeX-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'TeX-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'bibtex-mode "%{{{" "%}}} */" nil t)
(folding-add-to-marks-list 'bison-mode "/* {{{" "/* }}} */" " */" t)
(folding-add-to-marks-list 'c++-mode "// {{{" "// }}}" nil t)
(folding-add-to-marks-list 'c-mode "/* {{{" "/* }}} */" " */" t)
(folding-add-to-marks-list 'dcl-mode "! {{{" "! }}}" nil t)
(folding-add-to-marks-list 'change-log-mode "{{{" "}}}" nil t)
(folding-add-to-marks-list 'cperl-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'emacs-lisp-mode ";;{{{" ";;}}}" nil t)
(folding-add-to-marks-list 'erlang-mode "%%{{{" "%%}}}" nil t)
(folding-add-to-marks-list 'finder-mode "{{{" "}}}" nil t)
(folding-add-to-marks-list 'fortran-mode "! {{{" "! }}}" nil t)
(folding-add-to-marks-list 'f90-mode "! {{{" "! }}}" nil t)
(folding-add-to-marks-list 'generic-mode ";# " ";\$" nil t)
(folding-add-to-marks-list 'gofer-mode "-- {{{" "-- }}}" nil t)
(folding-add-to-marks-list 'html-mode "<!-- {{{ " "<!-- }}} -->" " -->" t)
(folding-add-to-marks-list 'icon-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'indented-text-mode "{{{" "}}}" nil t)
(folding-add-to-marks-list 'java-mode "// {{{" "// }}}" nil t)
(folding-add-to-marks-list 'javascript-mode "// {{{" "// }}}" nil t)
(folding-add-to-marks-list 'jde-mode "// {{{" "// }}}" nil t)
(folding-add-to-marks-list 'ksh-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'latex-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'lisp-interaction-mode ";;{{{" ";;}}}" nil t)
(folding-add-to-marks-list 'lisp-mode ";;{{{" ";;}}}" nil t)
(folding-add-to-marks-list 'm4-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'makefile-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'matlab-mode "%%%{{{" "%%%}}}" nil t)
(folding-add-to-marks-list 'meta-mode "% {{{" "% }}}" nil t)
(folding-add-to-marks-list 'ml-mode "(* {{{" "(* }}} *)" " *)" t)
(folding-add-to-marks-list 'modula-2-mode "(* {{{" "(* }}} *)" " *)" t)
(folding-add-to-marks-list 'nroff-mode "\\\\ {{{" "\\\\ }}}" nil t)
(folding-add-to-marks-list 'occam-mode "-- {{{" "-- }}}" nil t)
(folding-add-to-marks-list 'orwell-mode "{{{" "}}}" nil t)
(folding-add-to-marks-list 'pascal-mode "{ ((( " "{ ))) }" " }" t)
(folding-add-to-marks-list 'php-mode "// {{{" "// }}}" nil t)
(folding-add-to-marks-list 'perl-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'plain-TeX-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'plain-tex-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'prolog-mode "% {{{" "% }}}" nil t)
(folding-add-to-marks-list 'python-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'rexx-mode "/* {{{" "/* }}} */" " */" t)
(folding-add-to-marks-list 'sh-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'sh-script-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'shellscript-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'sgml-mode "<!-- [[[ " "<!-- ]]] -->" " -->" t)
(folding-add-to-marks-list 'simula-mode "! {{{" "! }}}" nil t)
(folding-add-to-marks-list 'sml-mode "(* {{{" "(* }}} *)" " *)" t)
(folding-add-to-marks-list 'sql-mode "-- {{{" "-- }}}" nil t)
(folding-add-to-marks-list 'tcl-mode "#{{{" "#}}}" nil t)
(folding-add-to-marks-list 'tex-mode "%{{{" "%}}}" nil t)
(folding-add-to-marks-list 'texinfo-mode "@c {{{" "@c {{{endfold}}}" " }}}" t)
(folding-add-to-marks-list 'text-mode "{{{" "}}}" nil t)
(folding-add-to-marks-list 'vhdl-mode "# {{{" "# }}}" nil t)
(folding-add-to-marks-list 'xerl-mode "%%{{{" "%%}}}" nil t)
(folding-add-to-marks-list 'xrdb-mode "! {{{" "! }}}" nil t)
(folding-add-to-marks-list 'fundamental-mode "# {{{" "# }}}" nil t)
(defun folding-subst-regions (list find replace)
"Substitute \\r and \\n using LIST FIND REPLACE."
(let ((buffer-read-only buffer-read-only) (modified (buffer-modified-p))
(font-lock-mode nil)
(lazy-lock-mode nil)
(overlay-p (folding-use-overlays-p))
(ask1 (symbol-function 'ask-user-about-supersession-threat))
(ask2 (symbol-function 'ask-user-about-lock)))
(if lazy-lock-mode (setq lazy-lock-mode t))
(unwind-protect
(progn
(setq buffer-read-only nil)
(or modified
(progn
(fset 'ask-user-about-supersession-threat
'(lambda (&rest x) nil))
(fset 'ask-user-about-lock
'(lambda (&rest x) nil))
(set-buffer-modified-p t))) (while list
(if overlay-p
(folding-flag-region (car list) (nth 1 list) (eq find ?\n))
(subst-char-in-region (car list) (nth 1 list) find replace t))
(setq list (cdr (cdr list)))))
(or modified
(unwind-protect
(set-buffer-modified-p nil)
(fset 'ask-user-about-supersession-threat ask1)
(fset 'ask-user-about-lock ask2))))))
(defun folding-narrow-to-region (&optional start end centre)
"Narrow to region START END, possibly CENTRE."
(let* ((the-window (selected-window))
(selected-buffer (window-buffer the-window))
(window-ring the-window)
(window the-window)
(point (point))
(buffer (current-buffer))
temp)
(unwind-protect
(progn
(unwind-protect
(progn
(if (folding-use-overlays-p)
(if start
(folding-narrow-aux start end t)
(folding-narrow-aux nil nil nil))
(if start
(narrow-to-region start end)
(widen)))
(setq point (point))
(set-window-buffer window buffer)
(while (progn
(and (eq buffer (window-buffer window))
(if centre
(progn
(select-window window)
(goto-char point)
(vertical-motion
(- (lsh (window-height window) -1)))
(set-window-start window (point))
(set-window-point window point))
(set-window-start window (or start 1))
(set-window-point window point)))
(not (eq (setq window (next-window window nil t))
window-ring)))))
nil (select-window the-window)) (unwind-protect
(if (not (eq buffer selected-buffer))
(set-window-buffer the-window selected-buffer)
(if (get-buffer "*scratch*")
(set-window-buffer the-window (get-buffer "*scratch*"))
(set-window-buffer
the-window (setq temp (generate-new-buffer " *temp*"))))
(set-window-buffer the-window buffer))
(and temp
(kill-buffer temp))))
(set-buffer buffer)
(goto-char (point)))))
(defun folding-end-mode-quickly ()
"Replace all ^M's with linefeeds and widen a folded buffer.
Only has any effect if Folding mode is active.
This should not in general be used for anything. It is used when changing
major modes, by being placed in kill-mode-tidy-alist, to tidy the buffer
slightly. It is similar to `(folding-mode 0)', except that it does not
restore saved keymaps etc. Repeat: Do not use this function. Its
behaviour is liable to change."
(and (boundp 'folding-mode)
(assq 'folding-mode
(buffer-local-variables))
folding-mode
(progn
(if (folding-use-overlays-p)
(folding-narrow-to-region nil nil)
(widen))
(folding-clear-stack)
(folding-subst-regions (list 1 (point-max)) ?\r ?\n))))
(defun folding-eval-current-buffer-open-folds (&optional printflag)
"Evaluate all of a folded buffer as Lisp code.
Unlike `eval-current-buffer', this function will evaluate all of a
buffer, even if it is folded. It will also work correctly on non-folded
buffers, so is a good candidate for being bound to a key if you program
in Emacs-Lisp.
It works by making a copy of the current buffer in another buffer,
unfolding it and evaluating it. It then deletes the copy.
Programs can pass argument PRINTFLAG which controls printing of output:
nil means discard it; anything else is stream for print."
(interactive)
(if (or (and (boundp 'folding-mode)
folding-mode))
(let ((temp-buffer
(generate-new-buffer (buffer-name))))
(message "Evaluating unfolded buffer...")
(save-restriction
(widen)
(copy-to-buffer temp-buffer 1 (point-max)))
(set-buffer temp-buffer)
(subst-char-in-region 1 (point-max) ?\r ?\n)
(let ((real-message-def (symbol-function 'message))
(suppress-eval-message))
(fset 'message
(function
(lambda (&rest args)
(setq suppress-eval-message t)
(fset 'message real-message-def)
(apply 'message args))))
(unwind-protect
(eval-current-buffer printflag)
(fset 'message real-message-def)
(kill-buffer temp-buffer))
(or suppress-eval-message
(message "Evaluating unfolded buffer... Done"))))
(eval-current-buffer printflag)))
(defcustom folding-isearch-install t
"*When non-nil, the isearch commands will handle folds."
:type 'boolean
:group 'folding)
(defvar folding-isearch-stack nil
"Temporary storage for `folding-stack' during isearch.")
(defvar folding-isearch-normal-cmds
'(isearch-repeat-forward
isearch-repeat-backward
isearch-toggle-regexp
isearch-toggle-case-fold
isearch-delete-char
isearch-abort
isearch-quote-char
isearch-other-control-char
isearch-other-meta-char
isearch-return-char
isearch-exit
isearch-printing-char
isearch-whitespace-chars
isearch-yank-word
isearch-yank-line
isearch-yank-kill
isearch-*-char
isearch-\|-char
isearch-mode-help
isearch-yank-x-selection
isearch-yank-x-clipboard)
"List if isearch commands doing normal search.")
(defvar folding-isearch-edit-enter-cmds
'(isearch-edit-string
isearch-ring-advance
isearch-ring-retreat
isearch-complete) "List of isearch commands which enters search string edit.")
(defvar folding-isearch-edit-exit-cmds
'(isearch-forward-exit-minibuffer isearch-reverse-exit-minibuffer
isearch-nonincremental-exit-minibuffer)
"List of isearch commands which exits search string edit.")
(defvar folding-isearch-mode-map nil
"Modified copy of the isearch keymap.")
(defun folding-isearch-hook-function ()
"Update the isearch keymaps for usage with folding mode."
(if (and (boundp 'folding-mode) folding-mode)
(let ((cmds (append folding-isearch-normal-cmds
folding-isearch-edit-enter-cmds
folding-isearch-edit-exit-cmds)))
(setq folding-isearch-mode-map (copy-keymap isearch-mode-map))
(make-local-variable 'minibuffer-local-isearch-map)
(setq minibuffer-local-isearch-map
(copy-keymap minibuffer-local-isearch-map))
(setq folding-isearch-stack folding-stack)
(while cmds
(substitute-key-definition
(car cmds)
(intern (concat "folding-" (symbol-name (car cmds))))
folding-isearch-mode-map)
(substitute-key-definition
(car cmds)
(intern (concat "folding-" (symbol-name (car cmds))))
minibuffer-local-isearch-map)
(setq cmds (cdr cmds)))
(cond
(folding-xemacs-p
(let ((f 'set-keymap-name))
(funcall f folding-isearch-mode-map 'folding-isearch-mode-map))
(cond
((and (boundp 'overriding-local-map) overriding-local-map)
(set-keymap-parent folding-isearch-mode-map overriding-local-map)
(setq overriding-local-map folding-isearch-mode-map))
(t
(setq minor-mode-map-alist
(cons (cons 'isearch-mode folding-isearch-mode-map)
(delq (assoc 'isearch-mode minor-mode-map-alist)
minor-mode-map-alist))))))
((boundp 'overriding-terminal-local-map)
(funcall (symbol-function 'set)
'overriding-terminal-local-map folding-isearch-mode-map))
((boundp 'overriding-local-map)
(setq overriding-local-map folding-isearch-mode-map))))))
(defun folding-isearch-end-hook-function ()
"Actions to perform at the end of isearch in folding mode."
(when (and (boundp 'folding-mode) folding-mode)
(kill-local-variable 'minibuffer-local-isearch-map)
(setq folding-stack folding-isearch-stack)))
(when folding-isearch-install
(add-hook 'isearch-mode-hook 'folding-isearch-hook-function)
(add-hook 'isearch-mode-end-hook 'folding-isearch-end-hook-function))
(let ((cmds folding-isearch-normal-cmds))
(while cmds
(eval
`(defun ,(intern (concat "folding-" (symbol-name (car cmds))))
nil
"Automatically generated"
(interactive)
(folding-isearch-general (quote ,(car cmds)))))
(setq cmds (cdr cmds))))
(defun folding-isearch-general (function)
"Execute isearch command FUNCTION and adjusts the folding."
(let* ((quit-isearch nil)
(area-beg (point-min))
(area-end (point-max))
pos)
(cond
(t
(save-restriction
(widen)
(condition-case nil
(funcall function)
(quit (setq quit-isearch t)))
(setq pos (point)))
(condition-case nil
(folding-region-has-folding-marks-p area-beg area-end)
(error (setq quit-isearch t)))
(folding-goto-char pos)))
(if quit-isearch
(signal 'quit '(isearch)))))
(defvar folding-isearch-current-buffer nil
"The buffer we are editing, so we can widen it when in minibuffer.")
(defun folding-isearch-edit-string ()
"Replace `isearch-edit-string' when in `folding-mode'."
(interactive)
(folding-isearch-start-edit 'isearch-edit-string))
(defun folding-isearch-ring-advance ()
"Replace `isearch-ring-advance' when in `folding-mode'."
(interactive)
(folding-isearch-start-edit 'isearch-ring-advance))
(defun folding-isearch-ring-retreat ()
"Replace `isearch-ring-retreat' when in `folding-mode'."
(interactive)
(folding-isearch-start-edit 'isearch-ring-retreat))
(defun folding-isearch-complete ()
"Replace `isearch-complete' when in `folding-mode'."
(interactive)
(folding-isearch-start-edit 'isearch-complete))
(defun folding-isearch-start-edit (function)
"Edit with function FUNCTION."
(let (pos)
(setq folding-isearch-current-buffer (current-buffer))
(save-restriction
(funcall function)
(setq pos (point)))
(folding-goto-char pos)))
(defun folding-isearch-forward-exit-minibuffer ()
"Replace `isearch-forward-exit-minibuffer' when in `folding-mode'."
(interactive)
(save-excursion
(set-buffer folding-isearch-current-buffer)
(widen))
(isearch-forward-exit-minibuffer))
(defun folding-isearch-reverse-exit-minibuffer ()
"Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'."
(interactive)
(save-excursion
(set-buffer folding-isearch-current-buffer)
(widen))
(isearch-reverse-exit-minibuffer))
(defun folding-isearch-nonincremental-exit-minibuffer ()
"Replace `isearch-reverse-exit-minibuffer' when in `folding-mode'."
(interactive)
(save-excursion
(set-buffer folding-isearch-current-buffer)
(widen))
(isearch-nonincremental-exit-minibuffer))
(if folding-xemacs-p
(let ((cmds (append folding-isearch-normal-cmds
folding-isearch-edit-enter-cmds
folding-isearch-edit-exit-cmds)))
(while cmds
(put (intern (concat "folding-" (symbol-name (car cmds))))
'isearch-command t)
(setq cmds (cdr cmds)))))
(defun folding-goto-char (pos)
"Goto character POS, changing fold if necessary."
(goto-char pos)
(if (eq pos (point)) nil
(folding-show-all) (goto-char pos))
(if (folding-point-folded-p pos)
(progn
(folding-shift-in) (setq folding-isearch-stack folding-stack)
(setq folding-stack '(folded))
(goto-char pos))))
(defun folding-point-folded-p (pos)
"Non-nil when POS is not visible."
(if (folding-use-overlays-p)
(let ((overlays (overlays-at (point)))
(found nil))
(while (and (not found) (overlayp (car overlays)))
(setq found (overlay-get (car overlays) 'fold)
overlays (cdr overlays)))
found)
(save-excursion
(goto-char pos)
(beginning-of-line)
(skip-chars-forward "^\r" pos)
(not (eq pos (point))))))
(defvar folding-comment-folding-table
'((c-mode
folding-comment-c-mode
folding-uncomment-c-mode))
"Table of functions to comment and uncomment folds.
Function is called with two arguments:
number start of fold mark
marker end of fold mark
Function must return:
(beg . end) start of fold, end of fold
Table Format:
'((MAJOR-MODE COMMENT-FUNCTION UNCOMMENT-FUNCTION) ..)")
(defun folding-insert-advertise-folding-mode ()
"Insert Small text describing where to the get the folding at point.
This may be useful 'banner' to inform other people why your code
is formatted like it is and how to view it correctly."
(interactive)
(let* ((prefix "")
(re (or comment-start-skip
(and comment-start
(concat "^[ \t]*" comment-start "+[ \t]*")))))
(when re
(save-excursion
(beginning-of-line)
(when (or (re-search-forward re nil t)
(progn
(goto-char (point-min))
(re-search-forward re nil t)))
(setq prefix (match-string 0)))))
(beginning-of-line)
(dolist (line
(list
"File layout controlled by Emacs folding.el available at: "
folding-package-url-location))
(insert "\n" prefix line))))
(defun folding-uncomment-mode-generic (beg end tag)
"In region (BEG . END) remove two TAG lines."
(re-search-forward tag (marker-position end))
(beginning-of-line)
(kill-line 1)
(re-search-forward tag (marker-position end))
(beginning-of-line)
(kill-line 1)
(cons beg end))
(defun folding-comment-mode-generic (beg end tag1 &optional tag2)
"Return (BEG . END) and Add two TAG1 and TAG2 lines."
(insert tag1)
(goto-char (marker-position end))
(insert (or tag2 tag1))
(cons beg end))
(defun folding-uncomment-c-mode (beg end)
"Uncomment region BEG END."
(folding-uncomment-mode-generic
beg end (regexp-quote " comment /* FOLDING -COM- */")))
(defun folding-comment-c-mode (beg end)
"Comment region BEG END."
(let* ((tag " /* FOLDING -COM- */"))
(folding-comment-mode-generic
beg end
(concat "#if comment" tag "\n")
(concat "#endif comment" tag "\n"))))
(defun folding-comment-fold (&optional uncomment)
"Comment or UNCOMMENT all text inside single fold.
If there are subfolds this function won't work as expected.
User must know that there are no subfolds.
The heading has -COM- at the end when the fold is commented.
Point must be over fold heading {{{ when function is called.
Note:
You can use this function only in modes that do _not_ have
`comment-end'. Ie. don't use this function in modes like C (/* */), because
nested comments are not allowed. See this:
/* {{{ fold */
code /* comment of the code */
/* }}} */
Fold can't know how to comment the `code' inside fold, because comments
do not nest.
Implementation detail:
{{{ FoldHeader-COM-
If the fold header has -COM- at the end, then the fold is supposed to
be commented. And if there is no -COM- then fold will be considered
as normal fold. Do not loose or add the -COM- yourself or it will
confuse the state of the fold.
References:
`folding-comment-folding-table'"
(interactive "P")
(let* ((state (folding-mark-look-at 'move))
(closed (eq 0 state))
(id "-COM-")
(opoint (point))
(mode-elt (assq major-mode folding-comment-folding-table))
comment
ret
beg
end)
(unless mode-elt
(if (stringp (nth 2 (folding-get-mode-marks major-mode)))
(error "\
Folding: function usage error, mode with `comment-end' is not supported.")))
(when (or (null comment-start)
(not (string-match "[^ \t\n]" comment-start)))
(error "Empty comment-start."))
(unless (memq state '( 0 1 11))
(error "Incorrect fold state. Point must be over {{{."))
(setq state (looking-at (concat ".*" id)))
(when (or (and uncomment state)
(and (null uncomment) (null state)))
(when closed (save-excursion (folding-show-current-entry)))
(folding-pick-move) (beginning-of-line)
(setq end (point-marker))
(goto-char opoint) (forward-line 1)
(setq beg (point))
(setq comment (concat comment-start id))
(cond
(mode-elt
(setq ret
(if uncomment
(funcall (nth 2 mode-elt) (point) end)
(funcall (nth 1 mode-elt) (point) end)))
(goto-char (cdr ret)))
(uncomment
(while (< (point) (marker-position end))
(if (looking-at comment)
(delete-region (point) (match-end 0)))
(forward-line 1)))
(t
(while (< (point) (marker-position end))
(if (not (looking-at comment))
(insert comment))
(forward-line 1))))
(setq end nil) (goto-char opoint)
(setq id (concat (or comment-start "") id (or comment-end "")))
(if (re-search-forward (regexp-quote id) beg t)
(delete-region (match-beginning 0) (match-end 0)))
(when (null uncomment)
(end-of-line)
(insert id))
(if closed
(folding-hide-current-entry))
(goto-char opoint))))
(defun folding-convert-to-major-folds ()
"Convert fold mark items according to `major-mode'.
This function replaces all fold markings }}} and {{{
with major mode's fold marks.
As a side effect also corrects all foldings to standard notation.
Eg. following, where correct folding-beg should be \"#{{{ \"
Note that /// marks foldings.
/// ;wrong fold
# /// ;too many spaces, fold format error
# ///title ;ok, but title too close
produces
#///
#///
#/// title
You must 'unfold' whole buffer before using this function."
(interactive)
(let (case-fold-search
(bm "{{{") (em "}}}") el b e e2 pp)
(catch 'out (unless (setq el (folding-get-mode-marks major-mode))
(throw 'out t)) (setq b (elt el 0)
e (elt el 1)
e2 (or (elt el 2) ""))
(save-excursion
(goto-char (point-min)) (while (re-search-forward (regexp-quote bm) nil t)
(setq pp (point))
(beginning-of-line)
(if (looking-at (regexp-quote b)) (goto-char pp) (delete-region (point) pp)
(insert b)
(when (not (string= "" e2))
(unless (looking-at (concat ".*" (regexp-quote e2)))
(end-of-line)
(insert e2)))))
(goto-char (point-min))
(while (re-search-forward (regexp-quote em)nil t)
(setq pp (point))
(beginning-of-line)
(if (looking-at (regexp-quote e))
(goto-char pp)
(delete-region (point) (progn (end-of-line) (point)))
(insert e)))))))
(defun folding-all-comment-blocks-in-region (beg end)
"Put all comments in folds inside BEG END.
Notice: Make sure there is no interfering folds inside the area,
because the results may and up corrupted.
This only works for modes that DO NOT have `comment-end'.
The `comment-start' must be left flushed in order to counted in.
After this
;; comment
;; comment
code
;; comment
;; comment
code
The result will be:
;; {{{ 1
;; comment
;; comment
;; }}}
code
;; {{{ 2
;; comment
;; comment
;; }}}
code"
(interactive "*r")
(unless comment-start
(error "Folding: Mode does not define `comment-start'"))
(when (and (stringp comment-end)
(string-match "[^ \t]" comment-end))
(error "Folding: Mode defines non-empty `comment-end'."))
(let* ((count 0)
(comment-regexp (concat "^" comment-start))
(marker (point-marker))
done)
(destructuring-bind (left right ignore)
(folding-get-mode-marks)
(if ignore (setq ignore ignore))
(string-match (concat (regexp-quote comment-start) "+") left)
(save-excursion
(goto-char beg)
(beginning-of-line)
(while (re-search-forward comment-regexp nil t)
(move-marker marker (point))
(setq done nil)
(beginning-of-line)
(forward-line -1)
(unless (looking-at (regexp-quote left))
(forward-line -1)
(unless (looking-at (regexp-quote left))
(goto-char (marker-position marker))
(beginning-of-line)
(insert left " " (int-to-string count) "\n\n")
(incf count)
(setq done t)))
(goto-char (marker-position marker))
(when done
(if (not (re-search-forward "^[ \t]*$" nil t))
(goto-char end))
(open-line 1)
(forward-line 1)
(insert right "\n")))))))
(defun folding-use-overlays-p ()
"Should folding use overlays?."
(if folding-allow-overlays
(if folding-xemacs-p
(load "overlay" 'noerr)
t)))
(defun folding-flag-region (from to flag)
"Hide or show lines from FROM to TO, according to FLAG.
If FLAG is nil then text is shown, while if FLAG is t the text is hidden."
(let ((inhibit-read-only t)
overlay)
(save-excursion
(goto-char from)
(end-of-line)
(cond
(flag
(setq overlay (make-overlay (point) to))
(folding-make-overlay-hidden overlay))
(t
(if (fboundp 'hs-discard-overlays)
(funcall (symbol-function 'hs-discard-overlays)
(point) to 'invisible t)))))))
(defun folding-make-overlay-hidden (overlay)
"Make OVERLAY hidden."
(overlay-put overlay 'fold t)
(overlay-put overlay 'invisible t)
(overlay-put overlay 'owner 'folding))
(defun folding-narrow-aux (start end arg)
"Narrow. Make overlay from `point-min' to START.
And from END t `point-min'. If ARG is nil, delete overlays."
(if (null arg)
(cond
(folding-narrow-overlays
(delete-overlay (car folding-narrow-overlays))
(delete-overlay (cdr folding-narrow-overlays))
(setq folding-narrow-overlays nil)))
(let ((overlay-beg (make-overlay (point-min) start))
(overlay-end (make-overlay end (point-max))))
(overlay-put overlay-beg 'folding-narrow t)
(overlay-put overlay-beg 'invisible t)
(overlay-put overlay-beg 'owner 'folding)
(overlay-put overlay-end 'folding-narrow t)
(overlay-put overlay-end 'invisible t)
(overlay-put overlay-end 'owner 'folding)
(setq folding-narrow-overlays (cons overlay-beg overlay-end)))))
(folding-install)
(provide 'folding)
(provide 'folding-isearch)
(run-hooks 'folding-load-hook)