Org-mode Source Block Visibility Cycling - emacs

I'm trying to add source blocks to the visibility cycling tree. Essentially I want a source block to be treated as a child of its heading. Consider the following org-mode document:
* Heading 1
** Heading 2
#+BEGIN_SRC R
print("hello world")
#+END_SRC
** Heading 3
I would like to be able to press TAB on heading one to cycle through the folding of the various parts including the source block. Currently org-mode does seem to have the facilities for folding the source block, because I can fold that if I go to #+BEGIN_SRC R and hit tab, but it doesnt seem to be being treated in the global cycling. Any suggestions to add it?
Thanks!

This is a slight modification of the code contained in the link mentioned in my first comment above: https://stackoverflow.com/a/21594242/2112489
All I did was replace the begin / end html regexp for the SRC regexp. Go ahead and give it a whirl and see if it is what you're looking for. I left my prior footnote modification in there.
(require 'org)
(defalias 'org-cycle-hide-drawers 'lawlist-block-org-cycle-hide-drawers)
(defun lawlist-block-org-cycle-hide-drawers (state)
"Re-hide all drawers, footnotes or html blocks after a visibility state change."
(when
(and
(derived-mode-p 'org-mode)
(not (memq state '(overview folded contents))))
(save-excursion
(let* (
(globalp (memq state '(contents all)))
(beg (if globalp (point-min) (point)))
(end
(cond
(globalp
(point-max))
((eq state 'children)
(save-excursion (outline-next-heading) (point)))
(t (org-end-of-subtree t)) )))
(goto-char beg)
(while
(re-search-forward
".*\\[fn\\|^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$" end t)
(lawlist-org-flag t))))))
(defalias 'org-cycle-internal-local 'lawlist-block-org-cycle-internal-local)
(defun lawlist-block-org-cycle-internal-local ()
"Do the local cycling action."
(let ((goal-column 0) eoh eol eos has-children children-skipped struct)
(save-excursion
(if (org-at-item-p)
(progn
(beginning-of-line)
(setq struct (org-list-struct))
(setq eoh (point-at-eol))
(setq eos (org-list-get-item-end-before-blank (point) struct))
(setq has-children (org-list-has-child-p (point) struct)))
(org-back-to-heading)
(setq eoh (save-excursion (outline-end-of-heading) (point)))
(setq eos (save-excursion (1- (org-end-of-subtree t t))))
(setq has-children
(or
(save-excursion
(let ((level (funcall outline-level)))
(outline-next-heading)
(and
(org-at-heading-p t)
(> (funcall outline-level) level))))
(save-excursion
(org-list-search-forward (org-item-beginning-re) eos t)))))
(beginning-of-line 2)
(if (featurep 'xemacs)
(while
(and
(not (eobp))
(get-char-property (1- (point)) 'invisible))
(beginning-of-line 2))
(while
(and
(not (eobp))
(get-char-property (1- (point)) 'invisible))
(goto-char (next-single-char-property-change (point) 'invisible))
(and
(eolp)
(beginning-of-line 2))))
(setq eol (point)))
(cond
((= eos eoh)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'empty))
(org-unlogged-message "EMPTY ENTRY")
(setq org-cycle-subtree-status nil)
(save-excursion
(goto-char eos)
(outline-next-heading)
(if (outline-invisible-p)
(org-flag-heading nil))))
((and
(or
(>= eol eos)
(not (string-match "\\S-" (buffer-substring eol eos))))
(or
has-children
(not (setq children-skipped
org-cycle-skip-children-state-if-no-children))))
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'children))
(if (org-at-item-p)
;; then
(org-list-set-item-visibility (point-at-bol) struct 'children)
;; else
(org-show-entry)
(org-with-limited-levels (show-children))
(when (eq org-cycle-include-plain-lists 'integrate)
(save-excursion
(org-back-to-heading)
(while (org-list-search-forward (org-item-beginning-re) eos t)
(beginning-of-line 1)
(let* (
(struct (org-list-struct))
(prevs (org-list-prevs-alist struct))
(end (org-list-get-bottom-point struct)))
(mapc (lambda (e) (org-list-set-item-visibility e struct 'folded))
(org-list-get-all-items (point) struct prevs))
(goto-char (if (< end eos) end eos)))))))
(org-unlogged-message "CHILDREN")
(save-excursion
(goto-char eos)
(outline-next-heading)
(if (outline-invisible-p)
(org-flag-heading nil)))
(setq org-cycle-subtree-status 'children)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'children)))
((or
children-skipped
(and
(eq last-command this-command)
(eq org-cycle-subtree-status 'children)))
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-pre-cycle-hook 'subtree))
(outline-flag-region eoh eos nil)
(org-unlogged-message
(if children-skipped
"SUBTREE (NO CHILDREN)"
"SUBTREE"))
(setq org-cycle-subtree-status 'subtree)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'subtree)))
((eq org-cycle-subtree-status 'subtree)
(org-show-subtree)
(message "ALL")
(setq org-cycle-subtree-status 'all))
(t
(run-hook-with-args 'org-pre-cycle-hook 'folded)
(outline-flag-region eoh eos t)
(org-unlogged-message "FOLDED")
(setq org-cycle-subtree-status 'folded)
(unless (org-before-first-heading-p)
(run-hook-with-args 'org-cycle-hook 'folded))))))
(defun lawlist-org-flag (flag)
"When FLAG is non-nil, hide any of the following: html code block;
footnote; or, the properties drawer. Otherwise make it visible."
(save-excursion
(beginning-of-line 1)
(cond
((looking-at ".*\\[fn")
(let* (
(begin (match-end 0))
end-footnote)
(if (re-search-forward "\\]"
(save-excursion (outline-next-heading) (point)) t)
(progn
(setq end-footnote (point))
(outline-flag-region begin end-footnote flag))
(user-error "Error beginning at point %s." begin))))
((looking-at "^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$")
(let* ((begin (match-end 0)))
(if (re-search-forward "^\\#\\+END_SRC.*$\\|^[ \t]*:END:"
(save-excursion (outline-next-heading) (point)) t)
(outline-flag-region begin (point-at-eol) flag)
(user-error "Error beginning at point %s." begin)))))))
(defun lawlist-toggle-block-visibility ()
"For this function to work, the cursor must be on the same line as the regexp."
(interactive)
(if
(save-excursion
(beginning-of-line 1)
(looking-at
".*\\[fn\\|^\\#\\+BEGIN_SRC.*$\\|^[ \t]*:PROPERTIES:[ \t]*$"))
(lawlist-org-flag (not (get-char-property (match-end 0) 'invisible)))
(message "Sorry, you are not on a line containing the beginning regexp.")))

Related

Best way to add per-line information visually in emacs?

I'm writing a minor mode for emacs which, at the very least, will calculate a numeric value for each line in a buffer. I want to display this visually, preferable neatly before each line.
I know some minor modes draw to the fringe, and I know overlays are an option too (are these related?), but I can't find a good example of what I want anywhere.
Basically, I want to have something like the line numbers from linum-mode, but they will need to change every time the buffer is modified (actually, only whenever the line they're on changes). Something like a character counter for each line would be a good example. And I'd like it to not break linum-mode, but not depend on it, etc, if possible.
Here is a quick example of one way to put an overlay after linum-mode numbers and before the line of text. I will need to give some thought about right-alignment of the character count.
NOTE:  This method contemplates that the linum-mode numbers are generated before the code that follows in this example. If the post-command-hook or the widow-scroll-functions hook is used to implement this proposed method, then those additions to the hooks would need to follow in time subsequently to the linum-mode functions attached to those same hooks.
The following example could be implemented with the post-command-hook and the window-scroll-functions hook. See the following link for an example of how to determine window-start and window-end before a redisplay occurs: https://stackoverflow.com/a/24216247/2112489
EDIT:  Added right-alignment of character count -- contemplates a maximum of three digits (i.e., up to 999 characters per line). The text after the character count overlays are now left-aligned.
(save-excursion
(let* (
(window-start (window-start))
(window-end (window-end)))
(goto-char window-end)
(while (re-search-backward "\n" window-start t)
(let* (
(pbol (point-at-bol))
(peol (point-at-eol))
(raw-char-count (abs (- peol pbol)))
(starting-column
(propertize (char-to-string ?\uE001)
'display
`((space :align-to 1)
(space :width 0))))
(colored-char-count
(propertize (number-to-string raw-char-count)
'face '(:background "gray50" :foreground "black")
'cursor t))
(one-spacer
(propertize (char-to-string ?\uE001)
'display
`((space :width 1))))
(two-spacers
(propertize (char-to-string ?\uE001)
'display
`((space :width 2))))
(final-char-count
(cond
((and
(< raw-char-count 100)
(> raw-char-count 9))
(concat one-spacer colored-char-count))
((< raw-char-count 10)
(concat two-spacers colored-char-count))
(t colored-char-count))) )
(overlay-put (make-overlay pbol pbol)
'before-string
(concat starting-column final-char-count two-spacers) )))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; M-x char-count-mode
(defvar char-count-p nil
"When `char-count-p` is non-`nil`, the overlays are present.")
(make-variable-buffer-local 'char-count-p)
(defvar char-count-this-command nil
"This local variable is set within the `post-command-hook`; and,
is also used by the `window-scroll-functions` hook.")
(make-variable-buffer-local 'char-count-this-command)
(defvar char-count-overlay-list nil
"List used to store overlays until they are removed.")
(make-variable-buffer-local 'char-count-overlay-list)
(defun char-count-post-command-hook ()
"Doc-string."
(setq char-count-this-command this-command)
(character-count-function))
(defun character-count-window-scroll-functions (win _start)
"Doc-string."
(character-count-function))
(defun equal-including-properties--remove-overlays (beg end name val)
"Remove the overlays using `equal`, instead of `eq`."
(when (and beg end name val)
(overlay-recenter end)
(dolist (o (overlays-in beg end))
(when (equal-including-properties (overlay-get o name) val)
(delete-overlay o)))))
(defun character-count-function ()
"Doc-string for the character-count-function."
(when
(and
char-count-mode
char-count-this-command
(window-live-p (get-buffer-window (current-buffer)))
(not (minibufferp))
(pos-visible-in-window-p (point)
(get-buffer-window (current-buffer) (selected-frame)) t) )
(remove-char-count-overlays)
(save-excursion
(let* (
counter
(selected-window (selected-window))
(window-start (window-start selected-window))
(window-end (window-end selected-window t)) )
(goto-char window-end)
(catch 'done
(while t
(when counter
(re-search-backward "\n" window-start t))
(when (not counter)
(setq counter t))
(let* (
(pbol (point-at-bol))
(peol (point-at-eol))
(raw-char-count (abs (- peol pbol)))
(starting-column
(propertize (char-to-string ?\uE001)
'display
`((space :align-to 1) (space :width 0))))
(colored-char-count
(propertize (number-to-string raw-char-count)
'face '(:background "gray50" :foreground "black")))
(one-spacer
(propertize (char-to-string ?\uE001)
'display
`((space :width 1))))
(two-spacers
(propertize (char-to-string ?\uE001)
'display
`((space :width 2))))
(final-char-count
(cond
((and
(< raw-char-count 100)
(> raw-char-count 9))
(concat one-spacer colored-char-count))
((< raw-char-count 10)
(concat two-spacers colored-char-count))
(t colored-char-count)))
(ov-string (concat starting-column final-char-count two-spacers)) )
(push ov-string char-count-overlay-list)
(overlay-put (make-overlay pbol pbol) 'before-string ov-string)
(when (<= pbol window-start)
(throw 'done nil)) )))
(setq char-count-p t)))
(setq char-count-this-command nil) ))
(defun remove-char-count-overlays ()
(when char-count-p
(require 'cl)
(setq char-count-overlay-list
(remove-duplicates char-count-overlay-list
:test (lambda (x y) (or (null y) (equal-including-properties x y)))
:from-end t))
(dolist (description char-count-overlay-list)
(equal-including-properties--remove-overlays (point-min) (point-max) 'before-string description))
(setq char-count-p nil) ))
(defun turn-off-char-count-mode ()
(char-count-mode -1))
(define-minor-mode char-count-mode
"A minor-mode that places the character count at the beginning of the line."
:init-value nil
:lighter " Char-Count"
:keymap nil
:global nil
:group nil
(cond
(char-count-mode
(setq scroll-conservatively 101)
(add-hook 'post-command-hook 'char-count-post-command-hook t t)
(add-hook 'window-scroll-functions
'character-count-window-scroll-functions t t)
(add-hook 'change-major-mode-hook 'turn-off-char-count-mode nil t)
(message "Turned ON `char-count-mode`."))
(t
(remove-char-count-overlays)
(remove-hook 'post-command-hook 'char-count-post-command-hook t)
(remove-hook 'window-scroll-functions
'character-count-window-scroll-functions t)
(remove-hook 'change-major-mode-hook 'turn-off-char-count-mode t)
(kill-local-variable 'scroll-conservatively)
(message "Turned OFF `char-count-mode`.") )))
(provide 'char-count)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Emacs -- runtime of putting / deleting overlays increases each run

I am looking for some assistance, please, to track down why the runtime of following overlay function increases with each successive run.
From what I can tell, the runtime should be the same if the text in the buffer remains the same -- i.e., just moving the cursor left / right should not increase the runtime (but it does).
I tried the following, but to no avail: (setq buffer-undo-list t); killing all local variables; (setq-default cache-long-scans nil).
This function is a scaled down version for purposes of creating a minimal working example. The full version starts of with a .1 second runtime and increases .1 seconds each successive run until the function becomes unusable.
(add-hook 'post-command-hook (lambda ()
(draw-vertical-line (window-start) (window-end))))
(defun draw-vertical-line (start end)
"Erase and redraw the vertical-line between START and END."
(measure-time
(setq my-cursor-point (point))
(setq my-current-col (current-column))
(save-excursion
(if (not (eq start (progn (goto-char start) (point-at-bol))))
(setq start (progn (goto-char start) (beginning-of-line) (point)))))
(save-excursion
(let* (my-last-column my-overlay beg-ov end-ov)
(goto-char end)
(mapc #'(lambda (o) (when (overlay-get o 'my-overlay-properties)
(delete-overlay o))) (overlays-in start end))
(goto-char end)
(while (re-search-backward "\n" start t)
(setq my-last-column (current-column))
(my-not-wrapped-line-function) )))))
(defun my-not-wrapped-line-function ()
(unless (eq (buffer-size) 0)
(setq beg-ov (save-excursion (move-to-column my-current-col) (point)))
(setq end-ov (+ 1 beg-ov))
(setq my-overlay (make-overlay beg-ov end-ov ))
(cond
;; text, excluding tabs
((and
(or
(< my-current-col my-last-column)
(and (eobp) (= my-current-col my-last-column)))
(not-tab-looking-back-p)
(not (eq my-cursor-point beg-ov)))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'text-exclude-tabs t)
(overlay-put my-overlay 'face '(:background "yellow" :foreground "black") ) )
;; tab with text to the right
((and
(tab-left-p)
(tab-looking-forward-p)
(tab-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-text-right t)
(overlay-put my-overlay 'face '(:foreground "purple" :weight bold) ) )
;; tab with text to the left
((and
(not-tab-left-p)
(tab-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-text-left t)
(overlay-put my-overlay 'face '(:foreground "green" :weight bold) ) )
;; tab sandwiched between a tab on each side
((and
(tab-p)
(tab-sandwiched-p)
(not (eq my-cursor-point beg-ov))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'tab-sandwiched t)
(overlay-put my-overlay 'face '(:foreground "orange" :weight bold) ) )
;; end of line, but not wrapped
((and
(= my-current-col my-last-column)
(eolp)
(not (eq my-cursor-point beg-ov)))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'eol t)
(overlay-put my-overlay 'face '(:foreground "brown" :weight bold) ) )
;; cursor -- not wrapped -- not end of line
((and
(not
(catch 'found
(dolist (ol (overlays-at beg-ov))
(and (overlay-get ol 'hl-p)
(throw 'found t)))))
(not (region-active-p))
(eq my-cursor-point beg-ov)
(not (eq (preceding-char) 9))
(< my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'my-cursor-not-wrapped-not-eol t)
(overlay-put my-overlay 'face '(:background "black" :weight bold) ) )
;; cursor -- end of line, but not a wrapped line
((and
(not (region-active-p))
(eq my-cursor-point beg-ov)
;; (not (eq (preceding-char) 9))
(= my-current-col my-last-column))
(overlay-put my-overlay 'my-overlay-properties t)
(overlay-put my-overlay 'my-cursor-eol-not-wrapped t)
(overlay-put my-overlay 'face '(:foreground "SteelBlue" :weight bold) ) ) )))
(defvar my-cursor-point nil
"Point used to prevent the formation of a cursor overlay.
It must be set within the function `draw-vertical-line`.")
(make-variable-buffer-local 'my-cursor-point)
(defsubst tab-left-p ()
(not (not (save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(unless (bobp) (backward-char 1)) (eq (char-after (point)) 9)))))
(defsubst not-tab-left-p ()
(not (save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(unless (bobp) (backward-char 1)) (eq (char-after (point)) 9))))
(defsubst tab-p ()
(save-excursion
(if my-current-col
(move-to-column my-current-col)
(current-column))
(eq (char-after (point)) 9)))
(defsubst not-tab-looking-back-p ()
(not (save-excursion
(if my-current-col
(move-to-column (+ 1 my-current-col))
(move-to-column (+ 1 (current-column))))
(eq (preceding-char) 9))))
(defsubst tab-looking-forward-p ()
(not (save-excursion
(if my-current-col
(move-to-column (+ 1 my-current-col))
(move-to-column (+ 1 current-column)))
(eq (char-after (point)) 9))))
(defsubst tab-sandwiched-p ()
(let ((my-current-col
(if my-current-col
my-current-col
(current-column))))
(not (eq
(save-excursion (move-to-column my-current-col)
(re-search-backward "\t" (point-at-bol) t) (point))
(save-excursion (move-to-column (+ my-current-col 1))
(re-search-backward "\t" (point-at-bol) t) (point))))))
(defmacro measure-time (&rest body)
"Measure the time it takes to evaluate BODY."
`(let ((time (current-time)))
,#body
(message "%.06f" (float-time (time-since time)))))
The current implementation of overlays is algorithnically very poor. Many basic operations (such as move-overlay, inserting/deleting text, or even sometimes just moving point) have time O(N), where N is the number of overlays. Sometimes you can tremendously speed things up by jusdicious use of overlay-recenter.
We know how to fix those algorithmic problems, and I'd be very happy to help someone work on the implementation.
Since my guess in the comments was correct, posting an actual answer for more visibility in case someone has a similar problem:
delete-overlay may not be doing what you expect. From the manual:
— Function: delete-overlay overlay
This function deletes overlay. The overlay continues to exist as a Lisp object, and its property list is unchanged, but it ceases to be attached to the buffer it belonged to, and ceases to have any effect on display.
A deleted overlay is not permanently disconnected. You can give it a position in a buffer again by calling move-overlay.
Maybe you have a giant pile of disconnected overlays eating up memory or causing a lot of processing.

How to maintain a selected region after it moves off screen

Is there a select region function that will preserve the selection if the region scrolls out of sight?
There are two kinds of selected region that I use on a daily basis. The first kind is with the shift key using an interactive code "^" in various movement functions -- e.g., left or right. The second kind is set-mark-command. In the first case, the highlighted region is deselected when I scroll up or down. In the second case, the highlighted region changes / moves if the selected region touches the top or bottom of the window when scrolling.
Ideally, I would like to select a region and then be free to move around the buffer from point-min to point-max.
I do not think there is such a function. The thing is emacs moves the point on scrolling (when the point moves out of window) that is why the selected region changes. See this question
That looks promising:
https://sites.google.com/site/steveyemacsutils/multi-select-el
There is also a multi-region.el at emacswiki.org
INITIAL (March 4, 2014):  First rough draft.  lawlist-mwheel-scroll is a modification of mwheel-scroll within mwheel.el -- the primary modification was to remove (let ((newpoint (point))) (goto-char opoint) (deactivate-mark) (goto-char newpoint)) and replace it with a fixed overlay based upon region-begin and region-end immediately before scrolling up or down.
EDIT (March 5, 2014):  Revised lawlist-mwheel-scroll to behave more like mwheel-scroll was originally intended within mwheel.el. Because regions can be selected from left to right, or from right to left, the original-point could be on either side of the selected region. Therefore, region-begin and region-end are not used to calculate whether the point has moved -- we use original-point and compare it to the potential new (point) after scrolling has occurred. Consolidated the contents of the prior function lawlist-select-region into the function lawlist-activate-deactivate-mark such that the former is no longer used.
(global-set-key (kbd "C-c c") 'lawlist-copy-selected-region)
(global-set-key (kbd "C-SPC") 'lawlist-activate-deactivate-mark)
(global-set-key [(wheel)] 'lawlist-mwheel-scroll)
(global-set-key [(wheel-down)] 'lawlist-mwheel-scroll)
(global-set-key [(wheel-up)] 'lawlist-mwheel-scroll)
(defvar region-begin nil
"The beginning of the selected region.")
(make-variable-buffer-local 'region-begin)
(defvar region-end nil
"The ending of the selected region.")
(make-variable-buffer-local 'region-end)
(defun lawlist-activate-deactivate-mark ()
(interactive)
(cond
;; newly selected region -- no prior overlay
((and
(region-active-p)
(not region-begin)
(not region-end))
(setq region-begin (region-beginning))
(setq region-end (region-end))
(overlay-put (make-overlay region-begin region-end) 'priority 1001)
(overlay-put (make-overlay region-begin region-end) 'face isearch-face)
(deactivate-mark t))
;; prior overlay + newly selected region
((and
(region-active-p)
region-begin
region-end)
(mapc 'delete-overlay (overlays-in region-begin region-end))
(setq region-begin (region-beginning))
(setq region-end (region-end))
(overlay-put (make-overlay region-begin region-end) 'priority 1001)
(overlay-put (make-overlay region-begin region-end) 'face isearch-face)
(deactivate-mark t))
;; prior overlay -- no selected region -- inside of overlay
((and
(not (region-active-p))
region-begin
region-end
(and
(>= (point) region-begin)
(<= (point) region-end)))
(message "[b]egin | [e]nd | [c]urrent | [d]eactivate")
(let* ((extend-region (read-char-exclusive)))
(cond
((eq extend-region ?b)
(set-marker (mark-marker) region-begin (current-buffer))
(setq mark-active t))
((eq extend-region ?e)
(set-marker (mark-marker) region-end (current-buffer))
(setq mark-active t))
((eq extend-region ?c)
(set-marker (mark-marker) (point) (current-buffer))
(setq mark-active t))
((eq extend-region ?d)
(deactivate-mark t))))
(mapc 'delete-overlay (overlays-in region-begin region-end)))
;; prior overlay -- no selected region -- outside of overlay
((and
(not (region-active-p))
region-begin
region-end
(or
(< (point) region-begin)
(> (point) region-end)))
(mapc 'delete-overlay (overlays-in region-begin region-end))
(setq region-begin nil)
(setq region-end nil)
(deactivate-mark t))
(t
(set-mark-command nil))))
(defun lawlist-copy-selected-region ()
(interactive)
(cond
;; prior overlay + newly selected region
((and
(region-active-p)
region-begin
region-end)
(mapc 'delete-overlay (overlays-in region-begin region-end))
(setq region-begin (region-beginning))
(setq region-end (region-end)))
;; prior overlay + no region selected
((and
(not (region-active-p))
region-begin
region-end)
(mapc 'delete-overlay (overlays-in region-begin region-end)))
;; newly selected region -- no prior overlay
((and
(region-active-p)
(not region-begin)
(not region-end))
(setq region-begin (region-beginning))
(setq region-end (region-end))) )
(if (and region-begin region-end)
(progn
(copy-region-as-kill region-begin region-end)
(message "copied: %s"
(concat
(truncate-string-to-width
(buffer-substring-no-properties region-begin region-end)
40)
(if
(>
(length
(buffer-substring-no-properties region-begin region-end))
40)
" . . ."
"")))
(setq region-begin nil)
(setq region-end nil))
(message "To copy, you must first select a region.")))
(defun lawlist-mwheel-scroll (event)
"Scroll up or down according to the EVENT.
This should only be bound to mouse buttons 4 and 5."
(interactive (list last-input-event))
(let* (
(curwin
(if mouse-wheel-follow-mouse
(prog1
(selected-window)
(select-window (mwheel-event-window event)))))
(buffer (window-buffer curwin))
(original-point
(with-current-buffer buffer
(when (eq (car-safe transient-mark-mode) 'only)
(point))))
(mods
(delq 'click (delq 'double (delq 'triple (event-modifiers event)))))
(amt (assoc mods mouse-wheel-scroll-amount)))
(with-current-buffer buffer
(when (eq (car-safe transient-mark-mode) 'only)
(setq region-begin (region-beginning))
(setq region-end (region-end))))
(if amt (setq amt (cdr amt))
(let ((list-elt mouse-wheel-scroll-amount))
(while (consp (setq amt (pop list-elt))))))
(if (floatp amt) (setq amt (1+ (truncate (* amt (window-height))))))
(when (and mouse-wheel-progressive-speed (numberp amt))
(setq amt (* amt (event-click-count event))))
(unwind-protect
(let ((button (mwheel-event-button event)))
(cond
((eq button mouse-wheel-down-event)
(condition-case nil (funcall mwheel-scroll-down-function amt)
(beginning-of-buffer
(unwind-protect
(funcall mwheel-scroll-down-function)
(set-window-start (selected-window) (point-min))))))
((eq button mouse-wheel-up-event)
(condition-case nil (funcall mwheel-scroll-up-function amt)
(end-of-buffer (while t (funcall mwheel-scroll-up-function)))))
(t (error "Bad binding in mwheel-scroll"))))
(if curwin (select-window curwin)))
(with-current-buffer buffer
(when
(and
original-point
(/= (point) original-point))
(overlay-put (make-overlay region-begin region-end) 'priority 1001)
(overlay-put (make-overlay region-begin region-end) 'face isearch-face)
(deactivate-mark t) )))
(when (and mouse-wheel-click-event mouse-wheel-inhibit-click-time)
(if mwheel-inhibit-click-event-timer
(cancel-timer mwheel-inhibit-click-event-timer)
(add-hook 'pre-command-hook 'mwheel-filter-click-events))
(setq mwheel-inhibit-click-event-timer
(run-with-timer mouse-wheel-inhibit-click-time nil
'mwheel-inhibit-click-timeout))))
(put 'lawlist-mwheel-scroll 'scroll-command t)

How to toggle letter cases in a region in emacs

How can I toggle the case of letters (switch uppercase letters to lowercase and lowercase letters to uppercase) of a region's text in Emacs?
There are listed commands for conversion but nothing for toggling.
Example:
PLease toggLE MY LETTER case
should become:
plEASE TOGGle my letter CASE
You can do it with a regexp substitution:
M-x replace-regexp RET
\([[:upper:]]+\)?\([[:lower:]]+\)? RET
\,(concat (downcase (or \1 "")) (upcase (or \2 ""))) RET
It's up to you to bind a key to this.
I wrote it for you; it did not have thorough testing, but it appears to do what you seek.
The logic behind it is to loop over every single character in the text. If the character is equal to the character in downcase, append it to the return string in upcase. If not, append it in downcase. At the end, delete region and insert the return string.
It works immediate on a page of text, though I'd be wary to use it on huge texts (should be fine still).
(defun toggle-case ()
(interactive)
(when (region-active-p)
(let ((i 0)
(return-string "")
(input (buffer-substring-no-properties (region-beginning) (region-end))))
(while (< i (- (region-end) (region-beginning)))
(let ((current-char (substring input i (+ i 1))))
(if (string= (substring input i (+ i 1)) (downcase (substring input i (+ i 1))))
(setq return-string
(concat return-string (upcase (substring input i (+ i 1)))))
(setq return-string
(concat return-string (downcase (substring input i (+ i 1)))))))
(setq i (+ i 1)))
(delete-region (region-beginning) (region-end))
(insert return-string))))
Commands upcase-region, downcase-region, andcapitalize-region are not toggles, and are perhaps the "conversion" commands you referred to. Here is a command that cycles among them.
(defvar cycle-region-capitalization-last 'upper)
(defun cycle-region-capitalization (&optional msgp)
"Cycle the region text among uppercase, lowercase and capitalized (title case)."
(interactive "p")
(setq cycle-region-capitalization-last
(case cycle-region-capitalization-last
(upper (call-interactively #'downcase-region) 'lower)
(lower (call-interactively #'capitalize-region) 'title)
(title (call-interactively #'upcase-region) 'upper)))
(when msgp (message "Region is now %scase" cycle-region-capitalization-last)))
If you mean letter case, then this function works nicely: http://ergoemacs.org/emacs/modernization_upcase-word.html
(defun toggle-letter-case ()
"Toggle the letter case of current word or text selection.
Toggles between: “all lower”, “Init Caps”, “ALL CAPS”."
(interactive)
(let (p1 p2 (deactivate-mark nil) (case-fold-search nil))
(if (region-active-p)
(setq p1 (region-beginning) p2 (region-end))
(let ((bds (bounds-of-thing-at-point 'word) ) )
(setq p1 (car bds) p2 (cdr bds)) ) )
(when (not (eq last-command this-command))
(save-excursion
(goto-char p1)
(cond
((looking-at "[[:lower:]][[:lower:]]") (put this-command 'state "all lower"))
((looking-at "[[:upper:]][[:upper:]]") (put this-command 'state "all caps") )
((looking-at "[[:upper:]][[:lower:]]") (put this-command 'state "init caps") )
((looking-at "[[:lower:]]") (put this-command 'state "all lower"))
((looking-at "[[:upper:]]") (put this-command 'state "all caps") )
(t (put this-command 'state "all lower") ) ) ) )
(cond
((string= "all lower" (get this-command 'state))
(upcase-initials-region p1 p2) (put this-command 'state "init caps"))
((string= "init caps" (get this-command 'state))
(upcase-region p1 p2) (put this-command 'state "all caps"))
((string= "all caps" (get this-command 'state))
(downcase-region p1 p2) (put this-command 'state "all lower")) )
) )
I liked the other answer's technique of comparing this-command and last-command,
so I've incorporated it into my old function. Here's the result:
(defun upcase-word-toggle ()
(interactive)
(let ((bounds (bounds-of-thing-at-point 'symbol))
beg end
regionp)
(if (eq this-command last-command)
(setq regionp (get this-command 'regionp))
(put this-command 'regionp nil))
(cond
((or (region-active-p) regionp)
(setq beg (region-beginning)
end (region-end))
(put this-command 'regionp t))
(bounds
(setq beg (car bounds)
end (cdr bounds)))
(t
(setq beg (point)
end (1+ beg))))
(save-excursion
(goto-char (1- beg))
(and (re-search-forward "[A-Za-z]" end t)
(funcall (if (char-upcasep (char-after))
'downcase-region
'upcase-region)
beg end)))))
(defun char-upcasep (letter)
(eq letter (upcase letter)))
(global-set-key (kbd "C->") 'upcase-word-toggle)

In-Place Word/Symbol Dabbrev Expand

Here's my extension to dabbrev-expand to support sub-string expansion.It works as expected, as far as I know. However I would find it even more useful if it supported in-symbol expansion similar to the behaviour of mdabbrev, which, by the way, is incomplete in terms of symbol-character and case-adjustment support. The pattern argument to dabbrev-substring-search, however, is only the pattern before point but for in-place expansions we need the pattern after point aswell. Why isn't this pattern available in hippie/dabbrev-expand and is there a preferred way to query it?
(defun dabbrev-substring-search (pattern &optional reverse limit syntax-context)
"Expand dabbrev substring. See:
http://www.emacswiki.org/cgi-bin/wiki/HippieExpand#toc5"
(let ((result ())
(regpat (cond ((not hippie-epxand-dabbrev-as-symbol)
(concat (regexp-quote pattern) W*))
;; ((eq (char-syntax (aref pattern 0)) ?_)
;; (concat (regexp-quote pattern)
;; "\\(\\sw\\|\\s_\\)*"))
(t
(concat "\\(?:"
Y<
"\\(" "\\(?:\\sw\\|\\s_\\)+" "\\)"
"\\(" (regexp-quote pattern) "\\)"
"\\(" "\\(?:\\sw\\|\\s_\\)*" "\\)"
Y>
"\\)"
"\\|"
"\\(?:"
Y<
"\\(" "\\(?:\\sw\\|\\s_\\)*" "\\)"
"\\(" (regexp-quote pattern) "\\)"
"\\(" "\\(?:\\sw\\|\\s_\\)+" "\\)"
Y>
"\\)"
)))))
(while (and (not result)
(if reverse
(re-search-backward regpat limit t)
(re-search-forward regpat limit t)))
(setq result (buffer-substring-no-properties (save-excursion
(goto-char (match-beginning 0))
;;(skip-syntax-backward "w_")
(point))
(match-end 0)))
(if (he-string-member result he-tried-table t)
(setq result nil))) ; ignore if bad prefix or already in table
(when nil
(when result
(let* ((p (point))
(end3 (match-end 3))
(beg2 (match-end 2))
(end2 (match-end 2))
(dummy (message "%s %s %s" end3 beg2 end2))
(beg (- end3 beg2)) ;begin offset from point
(end (- end3 end2))) ;end offset from point
(setq dabbrev-substring-match-region (cons beg end))
(hictx-generic (- p beg) (- p end) nil 'match 3))))
result))
;; Use: (dabbrev-substring-search "he")
(defun try-expand-dabbrev-substring-visible (old)
"Like `try-expand-dabbrev' but for visible part of buffer."
(interactive "P")
(let ((old-fun (symbol-function 'he-dabbrev-search)))
(fset 'he-dabbrev-search (symbol-function 'dabbrev-substring-search))
(unwind-protect (try-expand-dabbrev-visible old)
(fset 'he-dabbrev-search old-fun))))
(defun try-expand-dabbrev-substring (old)
"Like `try-expand-dabbrev' but for substring match."
(interactive "P")
(let ((old-fun (symbol-function 'he-dabbrev-search)))
(fset 'he-dabbrev-search (symbol-function 'dabbrev-substring-search))
(unwind-protect (try-expand-dabbrev old)
(fset 'he-dabbrev-search old-fun))))
(defun try-expand-dabbrev-substring-all-buffers (old)
"Like `try-expand-dabbrev-all-buffers' but for substring match."
(interactive "P")
(let ((old-fun (symbol-function 'he-dabbrev-search)))
(fset 'he-dabbrev-search (symbol-function 'dabbrev-substring-search))
(unwind-protect (try-expand-dabbrev-all-buffers old)
(fset 'he-dabbrev-search old-fun))))
which is activated for example using
(setq hippie-expand-try-functions-list
(append
'(
try-expand-dabbrev-substring-visible
try-expand-dabbrev-substring
try-expand-dabbrev-substring-all-buffers)))
This might or might not help. Like ordinary dabbrev, it works with the text before point, but candidate matching can be substring, regexp, or fuzzy (various kinds), in addition to prefix. Icicles - Dynamic Abbreviation