unpackaged.el
A collection of useful Emacs Lisp code that isn’t substantial enough to be packaged. This code will be maintained here so that it can be updated and improved over time.
This can be viewed directly on the repository or as HTML.
Contributions welcome!
Functions in this file generally use these helper packages:
- dash.el (including
dash-functional) - s.el
- use-package
Usage
There are two ways to use the code in this “unpackage”:
- Buffet
- Choose the the parts you want and copy them into your init files.
- Whole-hog
- Load the file
unpackaged.el, which is tangled from this Org file, e.g.(require 'unpackaged).
In general, the author will attempt to avoid code that modifies Emacs state by simply loading the tangled “unpackage,” but this is not strictly guaranteed. Please report any problems.
An easy way to “whole-hog it” is to use quelpa-use-package like this:
(use-package unpackaged
:quelpa (unpackaged :fetcher github :repo "alphapapa/unpackaged.el"))Contents
- Faces, fonts
- Buffers
- Meta
- Misc
- Org
- Agenda for subtree or region
- Agenda previews
- Convert Elisp to Org format
- Download and attach remote files
- Ensure blank lines between headings and before contents
- Export to HTML with useful anchors
- Surround region with emphasis or syntax characters
- Refile to datetree file using earliest/latest timestamp in entry
- org-return-dwim
- Read-only trees
- Sort tree by multiple methods at once
- Packages
- Programming
- Regular expressions
- Version control
- Web
Faces, fonts
font-compare
Compare TEXT displayed in FONTS. FONTS is a list of font specs.
Interactively, prompt for TEXT, using lorem-ipsum text if nil or the empty string, and select FONTS with x-select-font (select an already-selected font to end font selection).
Requires:
(defvar lorem-ipsum-text)
;;;###autoload
(defun unpackaged/font-compare (text fonts)
"Compare TEXT displayed in FONTS.
If TEXT is nil, use `lorem-ipsum' text. FONTS is a list of font
family strings and/or font specs.
Interactively, prompt for TEXT, using `lorem-ipsum' if left
empty, and select FONTS with `x-select-font' (select an
already-selected font to end font selection)."
(interactive (list (pcase (read-string "Text: ")
("" nil)
(else else))
(cl-loop for font = (x-select-font)
;; HACK: `x-select-font' calls quit() when the Cancel button is
;; pressed, so to avoid quit()'ing, we signal in-band by selecting a
;; font that has already been selected.
while (not (member font fonts))
collect font into fonts
finally return fonts)))
(setq text (or text (s-word-wrap 80 (s-join " " (progn
(require 'lorem-ipsum)
(seq-random-elt lorem-ipsum-text))))))
(with-current-buffer (get-buffer-create "*Font Compare*")
(erase-buffer)
(--each fonts
(let ((family (cl-typecase it
(font (symbol-name (font-get it :family)))
(string it))))
(insert family ": "
(propertize text
'face (list :family family))
"\n\n")))
(pop-to-buffer (current-buffer))))Buffers
ibuffer
;;; ibuffer
Filter groups
These commands toggle and move filter groups.
;;;###autoload
(defun unpackaged/ibuffer-toggle-all-filter-groups (toggle-empty)
"Toggle all filter groups.
With prefix, toggle `ibuffer-show-empty-filter-groups'."
(interactive "P")
(if toggle-empty
(progn
(setf ibuffer-show-empty-filter-groups (not ibuffer-show-empty-filter-groups))
(ibuffer-update nil))
(save-excursion
(goto-char (point-min))
(ibuffer-forward-filter-group)
(let ((start (point)))
(forward-char)
(while (not (<= (point) start))
(ibuffer-toggle-filter-group)
(ibuffer-forward-filter-group))))))
;;;###autoload
(defun unpackaged/ibuffer-filter-group-move-down ()
"Move filter group at point down."
(interactive)
(unpackaged/ibuffer-filter-group-move 'down))
;;;###autoload
(defun unpackaged/ibuffer-filter-group-move-up ()
"Move filter group at point up."
(interactive)
(unpackaged/ibuffer-filter-group-move 'up))
(defun unpackaged/ibuffer-filter-group-move (direction)
"Move filter group at point in DIRECTION, either `up' or `down'."
(ibuffer-kill-line)
(pcase-exhaustive direction
('down (ibuffer-forward-filter-group))
('up (ibuffer-backward-filter-group)))
(ibuffer-yank))Meta
Code used to help maintain this document. (Note: These links don’t work in GitHub’s renderer.)
Misc
Track metadata from MPRIS-supporting media player
Return the artist, album, and title of the track playing in MPRIS-supporting player. Returns a string in format ARTIST - ~ALBUM~: ~TITLE~ [PLAYER]. If no track is playing, returns nil. If more than one player is playing, uses the first one found in DBus. If PLAYER is non-nil, include the name of the player in the output string.
DBus is not a straightforward system to work with, so this may serve as a useful example, or save someone the trouble of figuring out how to get this metadata.
(cl-defun unpackaged/mpris-track (&optional player)
"Return the artist, album, and title of the track playing in MPRIS-supporting player.
Returns a string in format \"ARTIST - ALBUM: TITLE [PLAYER]\". If no track is
playing, returns nil. If more than one player is playing, uses
the first one found in DBus.
If PLAYER is non-nil, include the name of the player in the
output string."
(require 'dbus)
(when-let* ((mpris-services (--select (string-prefix-p "org.mpris.MediaPlayer2." it)
(dbus-list-known-names :session)))
(playing-service (--first (string= "Playing"
(dbus-get-property :session it
"/org/mpris/MediaPlayer2"
"org.mpris.MediaPlayer2.Player"
"PlaybackStatus"))
mpris-services))
(player-name (dbus-get-property :session playing-service
"/org/mpris/MediaPlayer2"
"org.mpris.MediaPlayer2"
"Identity"))
(metadata (dbus-get-property :session playing-service
"/org/mpris/MediaPlayer2"
"org.mpris.MediaPlayer2.Player"
"Metadata")))
;; `-let' makes it easy to get the actual strings out of the nested lists of lists of strings.
(-let (((&alist "xesam:artist" ((artists))
"xesam:album" ((album))
"xesam:title" ((title)))
metadata))
(format "%s - %s: %s%s" (s-join ", " artists) album title
(if player
(format " [%s]" player-name)
"")))))Org
Code for Org Mode.
Agenda for subtree or region
Display an agenda view for the current subtree or region. With prefix, display only TODO-keyword items.
;;;###autoload
(defun unpackaged/org-agenda-current-subtree-or-region (only-todos)
"Display an agenda view for the current subtree or region.
With prefix, display only TODO-keyword items."
(interactive "P")
(let ((starting-point (point))
header)
(with-current-buffer (or (buffer-base-buffer (current-buffer))
(current-buffer))
(if (use-region-p)
(progn
(setq header "Region")
(put 'org-agenda-files 'org-restrict (list (buffer-file-name (current-buffer))))
(setq org-agenda-restrict (current-buffer))
(move-marker org-agenda-restrict-begin (region-beginning))
(move-marker org-agenda-restrict-end
(save-excursion
;; If point is at beginning of line, include
;; heading on that line by moving forward 1.
(goto-char (1+ (region-end)))
(org-end-of-subtree))))
;; No region; restrict to subtree.
(save-excursion
(save-restriction
;; In case the command was called from an indirect buffer, set point
;; in the base buffer to the same position while setting restriction.
(widen)
(goto-char starting-point)
(setq header "Subtree")
(org-agenda-set-restriction-lock))))
;; NOTE: Unlike other agenda commands, binding `org-agenda-sorting-strategy'
;; around `org-search-view' seems to have no effect.
(let ((org-agenda-sorting-strategy '(priority-down timestamp-up))
(org-agenda-overriding-header header))
(org-search-view (if only-todos t nil) "*"))
(org-agenda-remove-restriction-lock t)
(message nil))))Agenda previews
Before:
After:
Requires:
(defface unpackaged/org-agenda-preview
'((t (:background "black")))
"Face for Org Agenda previews."
:group 'org)
;;;###autoload
(defun unpackaged/org-agenda-toggle-preview ()
"Toggle overlay of current item in agenda."
(interactive)
(if-let* ((overlay (ov-in 'unpackaged/org-agenda-preview t (line-end-position) (line-end-position))))
;; Hide existing preview
(ov-reset overlay)
;; Show preview
(let* ((entry-contents (--> (org-agenda-with-point-at-orig-entry
nil (buffer-substring (save-excursion
(unpackaged/org-forward-to-entry-content t)
(point))
(org-entry-end-position)))
s-trim
(concat "\n" it "\n"))))
(add-face-text-property 0 (length entry-contents)
'unpackaged/org-agenda-preview nil entry-contents)
(ov (line-end-position) (line-end-position)
'unpackaged/org-agenda-preview t
'before-string entry-contents))))
(defun unpackaged/org-forward-to-entry-content (&optional unsafe)
"Skip headline, planning line, and all drawers in current entry.
If UNSAFE is non-nil, assume point is on headline."
(unless unsafe
;; To improve performance in loops (e.g. with `org-map-entries')
(org-back-to-heading))
(cl-loop for element = (org-element-at-point)
for pos = (pcase element
(`(headline . ,_) (org-element-property :contents-begin element))
(`(,(or 'planning 'property-drawer 'drawer) . ,_) (org-element-property :end element)))
while pos
do (goto-char pos)))Convert Elisp to Org format
These functions convert Emacs Lisp code and docstrings to Org-formatted text, helpful for inserting into readme files (like this one).
;;;###autoload
(defun unpackaged/elisp-to-org ()
"Convert elisp code in region to Org syntax and put in kill-ring.
Extracts and converts docstring to Org text, and places code in
source block."
(interactive)
(let* ((raw (->> (buffer-substring (region-beginning) (region-end))
(replace-regexp-in-string (rx bol) " ")
(replace-regexp-in-string (rx bol (1+ blank) eol) "")))
(sexp (read raw))
(docstring (--when-let (-first #'stringp sexp)
(unpackaged/docstring-to-org it))))
(kill-new (concat docstring (when docstring "\n\n")
"#+BEGIN_SRC elisp" "\n"
raw "\n"
"#+END_SRC"))))
;;;###autoload
(defun unpackaged/docstring-to-org (docstring)
"Return DOCSTRING as formatted Org text.
Interactively, get text from region, and kill formatted Org text
to kill-ring."
(interactive (list (buffer-substring (region-beginning) (region-end))))
(cl-macrolet ((string-buffer--> (string &rest forms)
`(with-temp-buffer
(insert ,string)
,@(cl-loop for form in forms
collect `(goto-char (point-min))
collect form)
(buffer-string))))
(--> (string-buffer--> docstring
(unpackaged/caps-to-code (point-min) (point-max))
(unpackaged/symbol-quotes-to-org-code (point-min) (point-max))
(unfill-region (point-min) (point-max))
(while (re-search-forward (rx bol (group (1+ blank))) nil t)
(replace-match "" t t nil 1))
(when (looking-at "\"")
(delete-char 1))
(when (progn
(goto-char (point-max))
(looking-back "\"" nil))
(delete-char -1)))
(if (called-interactively-p 'interactive)
(progn
(message it)
(kill-new it))
it))))
;;;###autoload
(defun unpackaged/caps-to-code (beg end)
"Convert all-caps words in region to Org code emphasis."
(interactive "r")
(let ((case-fold-search nil))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(while (re-search-forward (rx (or space bol)
(group (1+ upper))
(or space eol (char punct)))
nil t)
(setf (buffer-substring (match-beginning 1) (match-end 1))
(concat "~" (match-string 1) "~"))
(goto-char (match-end 0)))))))
;;;###autoload
(defun unpackaged/symbol-quotes-to-org-code (beg end)
"Change Emacs `symbol' quotes to Org =symbol= quotes in region."
(interactive "r")
(save-excursion
(save-restriction
(goto-char beg)
(narrow-to-region beg end)
(while (re-search-forward (rx (or "`" "‘") (group (1+ (or "-" word))) "'") nil t)
(replace-match (concat "~" (match-string 1) "~") t)))))Download and attach remote files
Download file at URL and attach with org-attach. Interactively, look for URL at point, in X clipboard, and in kill-ring, prompting if not found. With prefix, prompt for URL.
Requires:
;;;###autoload
(defun unpackaged/org-attach-download (url)
"Download file at URL and attach with `org-attach'.
Interactively, look for URL at point, in X clipboard, and in
kill-ring, prompting if not found. With prefix, prompt for URL."
(interactive (list (if current-prefix-arg
(read-string "URL: ")
(or (org-element-property :raw-link (org-element-context))
(org-web-tools--get-first-url)
(read-string "URL: ")))))
(when (yes-or-no-p (concat "Attach file at URL: " url))
(let* ((temp-dir (make-temp-file "org-attach-download-" 'dir))
(basename (file-name-nondirectory (directory-file-name url)))
(local-path (expand-file-name basename temp-dir))
size)
(unwind-protect
(progn
(url-copy-file url local-path 'ok-if-exists 'keep-time)
(setq size (file-size-human-readable
(file-attribute-size
(file-attributes local-path))))
(org-attach-attach local-path nil 'mv)
(message "Attached %s (%s)" url size))
(delete-directory temp-dir)))))Ensure blank lines between headings and before contents
Ensure that blank lines exist between headings and between headings and their contents. With prefix, operate on whole buffer. Ensures that blank lines exist after each headings’s drawers.
For those who prefer to maintain blank lines between headings, this makes it easy to automatically add them where necessary, to a subtree or the whole buffer. It also adds blank lines after drawers. Works well with *~org-return-dwim~.
;;;###autoload
(defun unpackaged/org-fix-blank-lines (prefix)
"Ensure that blank lines exist between headings and between headings and their contents.
With prefix, operate on whole buffer. Ensures that blank lines
exist after each headings's drawers."
(interactive "P")
(org-map-entries (lambda ()
(org-with-wide-buffer
;; `org-map-entries' narrows the buffer, which prevents us from seeing
;; newlines before the current heading, so we do this part widened.
(while (not (looking-back "\n\n" nil))
;; Insert blank lines before heading.
(insert "\n")))
(let ((end (org-entry-end-position)))
;; Insert blank lines before entry content
(forward-line)
(while (and (org-at-planning-p)
(< (point) (point-max)))
;; Skip planning lines
(forward-line))
(while (re-search-forward org-drawer-regexp end t)
;; Skip drawers. You might think that `org-at-drawer-p' would suffice, but
;; for some reason it doesn't work correctly when operating on hidden text.
;; This works, taken from `org-agenda-get-some-entry-text'.
(re-search-forward "^[ \t]*:END:.*\n?" end t)
(goto-char (match-end 0)))
(unless (or (= (point) (point-max))
(org-at-heading-p)
(looking-at-p "\n"))
(insert "\n"))))
t (if prefix
nil
'tree)))Export to HTML with useful anchors
This minor mode causes Org HTML export to use heading titles for HTML IDs and anchors. For example, instead of:
<li><a href="#org11177f0">Usage...
<li><a href="#orge2a172e">Faces, fonts...You get:
<li><a href="#Usage">Usage...
<li><a href="#Faces%2C%20fonts">Faces, fonts...So links to sections of the exported HTML will remain useful, rather than being different, random numbers every time the document is exported. If an anchor is not unique, its ancestor headings are prepended one-at-a-time until unique, and when no more ancestors remain, a number is appended and incremented until unique. For an example of how this works out in practice, see the links made to headings here, of which there are many having the same name (e.g. Tools, Libraries, etc).
Note that this is somewhat of a hack, and it probably breaks some feature deep inside Org Export. But it seems to work, and it solves the problem!
(define-minor-mode unpackaged/org-export-html-with-useful-ids-mode
"Attempt to export Org as HTML with useful link IDs.
Instead of random IDs like \"#orga1b2c3\", use heading titles,
made unique when necessary."
:global t
(if unpackaged/org-export-html-with-useful-ids-mode
(progn
(advice-add #'org-export-new-title-reference :override #'unpackaged/org-export-new-title-reference)
(advice-add #'org-export-get-reference :override #'unpackaged/org-export-get-reference))
(advice-remove #'org-export-new-title-reference #'unpackaged/org-export-new-title-reference)
(advice-remove #'org-export-get-reference #'unpackaged/org-export-get-reference)))
(defun unpackaged/org-export-get-reference (datum info)
"Like `org-export-get-reference', except uses heading titles instead of random numbers."
(let ((cache (plist-get info :internal-references)))
(or (car (rassq datum cache))
(let* ((crossrefs (plist-get info :crossrefs))
(cells (org-export-search-cells datum))
;; Preserve any pre-existing association between
;; a search cell and a reference, i.e., when some
;; previously published document referenced a location
;; within current file (see
;; `org-publish-resolve-external-link').
;;
;; However, there is no guarantee that search cells are
;; unique, e.g., there might be duplicate custom ID or
;; two headings with the same title in the file.
;;
;; As a consequence, before re-using any reference to
;; an element or object, we check that it doesn't refer
;; to a previous element or object.
(new (or (cl-some
(lambda (cell)
(let ((stored (cdr (assoc cell crossrefs))))
(when stored
(let ((old (org-export-format-reference stored)))
(and (not (assoc old cache)) stored)))))
cells)
(when (org-element-property :raw-value datum)
;; Heading with a title
(unpackaged/org-export-new-title-reference datum cache))
;; NOTE: This probably breaks some Org Export
;; feature, but if it does what I need, fine.
(org-export-format-reference
(org-export-new-reference cache))))
(reference-string new))
;; Cache contains both data already associated to
;; a reference and in-use internal references, so as to make
;; unique references.
(dolist (cell cells) (push (cons cell new) cache))
;; Retain a direct association between reference string and
;; DATUM since (1) not every object or element can be given
;; a search cell (2) it permits quick lookup.
(push (cons reference-string datum) cache)
(plist-put info :internal-references cache)
reference-string))))
(defun unpackaged/org-export-new-title-reference (datum cache)
"Return new reference for DATUM that is unique in CACHE."
(cl-macrolet ((inc-suffixf (place)
`(progn
(string-match (rx bos
(minimal-match (group (1+ anything)))
(optional "--" (group (1+ digit)))
eos)
,place)
;; HACK: `s1' instead of a gensym.
(-let* (((s1 suffix) (list (match-string 1 ,place)
(match-string 2 ,place)))
(suffix (if suffix
(string-to-number suffix)
0)))
(setf ,place (format "%s--%s" s1 (cl-incf suffix)))))))
(let* ((title (org-element-property :raw-value datum))
(ref (url-hexify-string (substring-no-properties title)))
(parent (org-element-property :parent datum)))
(while (--any (equal ref (car it))
cache)
;; Title not unique: make it so.
(if parent
;; Append ancestor title.
(setf title (concat (org-element-property :raw-value parent)
"--" title)
ref (url-hexify-string (substring-no-properties title))
parent (org-element-property :parent parent))
;; No more ancestors: add and increment a number.
(inc-suffixf ref)))
ref)))Surround region with emphasis or syntax characters
Define and bind interactive commands for each of KEYS that surround the region or insert text. Commands are bound in org-mode-map to each of KEYS. If the region is active, commands surround it with the key character, otherwise call org-self-insert-command.
;;;###autoload
(defmacro unpackaged/def-org-maybe-surround (&rest keys)
"Define and bind interactive commands for each of KEYS that surround the region or insert text.
Commands are bound in `org-mode-map' to each of KEYS. If the
region is active, commands surround it with the key character,
otherwise call `org-self-insert-command'."
`(progn
,@(cl-loop for key in keys
for name = (intern (concat "unpackaged/org-maybe-surround-" key))
for docstring = (format "If region is active, surround it with \"%s\", otherwise call `org-self-insert-command'." key)
collect `(defun ,name ()
,docstring
(interactive)
(if (region-active-p)
(let ((beg (region-beginning))
(end (region-end)))
(save-excursion
(goto-char end)
(insert ,key)
(goto-char beg)
(insert ,key)))
(call-interactively #'org-self-insert-command)))
collect `(define-key org-mode-map (kbd ,key) #',name))))Used like:
(unpackaged/def-org-maybe-surround "~" "=" "*" "/" "+")Refile to datetree file using earliest/latest timestamp in entry
Refile current entry to datetree using timestamp found in entry. WHICH should be earliest or latest. If SUBTREE-P is non-nil, search whole subtree.
This is sort of like archiving to a datetree, but it uses either the earliest or latest timestamp found in the entry or subtree rather than the current date. It’s helpful if you have an entry with lots of timestamps or log entries, and you’re done with it, and you want to file it in a datetree in a leaf matching either when you started working on the entry or when you finished, using the first or last timestamp found anywhere in the entry.
Note: If you can think of a more concise name for this command, please send it in!
Requires: ts
;;;###autoload
(defun unpackaged/org-refile-to-datetree-using-ts-in-entry (which-ts file &optional subtree-p)
"Refile current entry to datetree in FILE using timestamp found in entry.
WHICH should be `earliest' or `latest'. If SUBTREE-P is non-nil,
search whole subtree."
(interactive (list (intern (completing-read "Which timestamp? " '(earliest latest)))
(read-file-name "File: " (concat org-directory "/") nil 'mustmatch nil
(lambda (filename)
(string-suffix-p ".org" filename)))
current-prefix-arg))
(require 'ts)
(let* ((sorter (pcase which-ts
('earliest #'ts<)
('latest #'ts>)))
(tss (unpackaged/org-timestamps-in-entry subtree-p))
(ts (car (sort tss sorter)))
(date (list (ts-month ts) (ts-day ts) (ts-year ts))))
(unpackaged/org-refile-to-datetree file :date date)))
;;;###autoload
(defun unpackaged/org-timestamps-in-entry (&optional subtree-p)
"Return timestamp objects for all Org timestamps in entry.
If SUBTREE-P is non-nil (interactively, with prefix), search
whole subtree."
(interactive (list current-prefix-arg))
(save-excursion
(let* ((beg (org-entry-beginning-position))
(end (if subtree-p
(org-end-of-subtree)
(org-entry-end-position))))
(goto-char beg)
(cl-loop while (re-search-forward org-tsr-regexp-both end t)
for ts = (save-excursion
(goto-char (match-beginning 0))
(org-element-timestamp-parser))
collect (ts-parse-org ts)))))
;;;###autoload
(cl-defun unpackaged/org-refile-to-datetree (file &key (date (calendar-current-date)) entry)
"Refile ENTRY or current node to entry for DATE in datetree in FILE."
(interactive (list (read-file-name "File: " (concat org-directory "/") nil 'mustmatch nil
(lambda (filename)
(string-suffix-p ".org" filename)))))
;; If org-datetree isn't loaded, it will cut the tree but not file
;; it anywhere, losing data. I don't know why
;; org-datetree-file-entry-under is in a separate package, not
;; loaded with the rest of org-mode.
(require 'org-datetree)
(unless entry
(org-cut-subtree))
;; Using a condition-case to be extra careful. In case the refile
;; fails in any way, put cut subtree back.
(condition-case err
(with-current-buffer (or (org-find-base-buffer-visiting file)
(find-file-noselect file))
(org-datetree-file-entry-under (or entry (car kill-ring)) date)
(save-buffer))
(error (unless entry
(org-paste-subtree))
(message "Unable to refile! %s" err))))org-return-dwim
A helpful replacement for org-return. With prefix, call org-return.
On headings, move point to position after entry content. In lists, insert a new item or end the list, with checkbox if appropriate. In tables, insert a new row or end the table.
Inspired by John Kitchin.
(defun unpackaged/org-element-descendant-of (type element)
"Return non-nil if ELEMENT is a descendant of TYPE.
TYPE should be an element type, like `item' or `paragraph'.
ELEMENT should be a list like that returned by `org-element-context'."
(when-let* ((parent (org-element-property :parent element)))
(or (eq type (car parent))
(unpackaged/org-element-descendant-of type parent))))
;;;###autoload
(defun unpackaged/org-return-dwim (&optional default)
"A helpful replacement for `org-return'. With prefix, call `org-return'.
On headings, move point to position after entry content. In
lists, insert a new item or end the list, with checkbox if
appropriate. In tables, insert a new row or end the table."
;; Inspired by John Kitchin: http://kitchingroup.cheme.cmu.edu/blog/2017/04/09/A-better-return-in-org-mode/
(interactive "P")
(if default
(org-return)
(cond
;; Act depending on context around point.
;; NOTE: I prefer RET to not follow links, but by uncommenting this block, links will be
;; followed.
;; ((eq 'link (car (org-element-context)))
;; ;; Link: Open it.
;; (org-open-at-point-global))
((org-at-heading-p)
;; Heading: Move to position after entry content.
;; NOTE: This is probably the most interesting feature of this function.
(let ((heading-start (org-entry-beginning-position)))
(goto-char (org-entry-end-position))
(cond ((and (org-at-heading-p)
(= heading-start (org-entry-beginning-position)))
;; Entry ends on its heading; add newline after
(end-of-line)
(insert "\n\n"))
(t
;; Entry ends after its heading; back up
(forward-line -1)
(end-of-line)
(when (org-at-heading-p)
;; At the same heading
(forward-line)
(insert "\n")
(forward-line -1))
(while (not (looking-back (rx (repeat 3 (seq (optional blank) "\n")))))
(insert "\n"))
(forward-line -1)))))
((org-at-item-checkbox-p)
;; Checkbox: Insert new item with checkbox.
(org-insert-todo-heading nil))
((org-in-item-p)
;; Plain list. Yes, this gets a little complicated...
(let ((context (org-element-context)))
(if (or (eq 'plain-list (car context)) ; First item in list
(and (eq 'item (car context))
(not (eq (org-element-property :contents-begin context)
(org-element-property :contents-end context))))
(unpackaged/org-element-descendant-of 'item context)) ; Element in list item, e.g. a link
;; Non-empty item: Add new item.
(org-insert-item)
;; Empty item: Close the list.
;; TODO: Do this with org functions rather than operating on the text. Can't seem to find the right function.
(delete-region (line-beginning-position) (line-end-position))
(insert "\n"))))
((when (fboundp 'org-inlinetask-in-task-p)
(org-inlinetask-in-task-p))
;; Inline task: Don't insert a new heading.
(org-return))
((org-at-table-p)
(cond ((save-excursion
(beginning-of-line)
;; See `org-table-next-field'.
(cl-loop with end = (line-end-position)
for cell = (org-element-table-cell-parser)
always (equal (org-element-property :contents-begin cell)
(org-element-property :contents-end cell))
while (re-search-forward "|" end t)))
;; Empty row: end the table.
(delete-region (line-beginning-position) (line-end-position))
(org-return))
(t
;; Non-empty row: call `org-return'.
(org-return))))
(t
;; All other cases: call `org-return'.
(org-return)))))Read-only trees
This code applies the read-only text-property to trees tagged read_only, preventing them from being modified accidentally. (Note: If read-only headings appear in an Agenda buffer, it can cause slightly unusual behavior. Usually this is not an issue.) This was originally inspired by John Kitchin’s blog article and later rewritten in a faster version.
To use, load these functions, and then add to this hook to automatically mark read-only sections when an Org file is loaded:
(add-hook 'org-mode-hook 'unpackaged/org-mark-read-only)The functions may also be called interactively as needed.
(defun unpackaged/org-next-heading-tagged (tag)
"Move to beginning of next heading tagged with TAG and return point, or return nil if none found."
(when (re-search-forward (rx-to-string `(seq bol (1+ "*") (1+ blank) (optional (1+ not-newline) (1+ blank))
;; Beginning of tags
":"
;; Possible other tags
(0+ (seq (1+ (not (any ":" blank))) ":") )
;; The tag that matters
,tag ":"))
nil 'noerror)
(goto-char (match-beginning 0))))
;;;###autoload
(defun unpackaged/org-mark-read-only ()
"Mark all entries in the buffer tagged \"read_only\" with read-only text properties."
(interactive)
(org-with-wide-buffer
(goto-char (point-min))
(while (unpackaged/org-next-heading-tagged "read_only")
(add-text-properties (point) (org-end-of-subtree t)
'(read-only t)))))
(defun unpackaged/org-remove-read-only ()
"Remove read-only text properties from Org entries tagged \"read_only\" in current buffer."
(interactive)
(let ((inhibit-read-only t))
(org-with-wide-buffer
(goto-char (point-min))
(while (unpackaged/org-next-heading-tagged "read_only")
(remove-text-properties (point) (org-end-of-subtree t)
'(read-only t))))))Sort tree by multiple methods at once
Call org-sort-entries with multiple sorting methods specified in KEYS.
This is much easier than doing C-c ^ KEY several times in a row.
;;;###autoload
(defun unpackaged/org-sort-multi (keys)
"Call `org-sort-entries' with multiple sorting methods specified in KEYS."
;; Message copied from `org-sort-entries'.
(interactive (list (read-string "Sort by: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc
[t]ime [s]cheduled [d]eadline [c]reated cloc[k]ing
A/N/P/R/O/F/T/S/D/C/K means reversed: ")))
(seq-do (lambda (key)
(org-sort-entries nil key))
(nreverse keys)))Packages
Delete all installed versions of a package
Delete all versions of package named NAME. NAME may be a string or symbol.
(defun unpackaged/package-delete-all-versions (name &optional force)
"Delete all versions of package named NAME.
NAME may be a string or symbol."
;; Copied from `package-delete'.
(let* ((package-name (cl-typecase name
(string (intern name))
(symbol name)))
(user-packages-list (->> package-alist
;; Just to be safe, we ignore built-ins.
(-select (-not #'package-built-in-p))))
(matching-versions (--select (eql (car it) package-name) user-packages-list)))
;; Safety checks.
(cl-loop for (symbol first-desc . rest) in matching-versions
do (progn
(unless force
(when-let* ((dependent (package--used-elsewhere-p first-desc)))
(error "Package `%s' depends on `%s'" (package-desc-name dependent) package-name)))
(unless (string-prefix-p (file-name-as-directory (expand-file-name package-user-dir))
(expand-file-name (package-desc-dir first-desc)))
(error "Package `%s' is a system package"))))
;; Checks passed: delete packages.
(cl-loop for (symbol . descs) in matching-versions
do (--each descs
(package-delete it force)))))Upgrade a quelpa-use-package form’s package
Eval the current use-package form with quelpa-upgrade-p true. Deletes old versions of the package first to remove obsolete versions.
This makes it easy to upgrade a package you install with quelpa-use-package without having to add :upgrade t to the form, which would cause Quelpa to always upgrade the package every time Emacs loads.
Requires:
;;;###autoload
(defun unpackaged/quelpa-use-package-upgrade ()
"Eval the current `use-package' form with `quelpa-upgrade-p' true.
Deletes the package first to remove obsolete versions."
(interactive)
(save-excursion
(if (or (looking-at (rx "(use-package "))
(let ((limit (save-excursion
(or (re-search-backward (rx bol "("))
(point-min)))))
;; Don't go past previous top-level form
(re-search-backward (rx "(use-package ") limit t)))
(progn
(pcase-let* ((`(use-package ,package-name . ,rest) (read (current-buffer))))
(cl-assert package-name nil "Can't determine package name")
(cl-assert (cl-loop for sexp in rest
thereis (eql sexp :quelpa))
nil "`:quelpa' form not found")
(unpackaged/package-delete-all-versions package-name 'force))
(let ((quelpa-upgrade-p t))
(call-interactively #'eval-defun)))
(user-error "Not in a `use-package' form"))))Upgrade one package in the package menu
Mark current package for upgrading (i.e. also mark obsolete version for deletion.)
(use-package package
:bind (:map package-menu-mode-map
("t" . #'unpackaged/package-menu-upgrade-package))
:config
;; I think the `use-package' form takes care of autoloading here.
(defun unpackaged/package-menu-upgrade-package ()
"Mark current package for upgrading (i.e. also mark obsolete version for deletion.)"
(interactive)
(when-let ((upgrades (package-menu--find-upgrades))
(description (tabulated-list-get-id))
(name (package-desc-name description))
(upgradable (cdr (assq name upgrades))))
;; Package is upgradable
(save-excursion
(goto-char (point-min))
(while (not (eobp))
(let* ((current-description (tabulated-list-get-id))
(current-name (package-desc-name current-description)))
(when (equal current-name name)
(cond ((equal description current-description)
(package-menu-mark-install)
(forward-line -1))
(t (package-menu-mark-delete)))))
(forward-line 1))))))Programming
Flexibly fill/unfill paragraphs
Fill paragraph, incrementing fill column each time this command is repeated. When the command is called for the first time in a sequence, unfill to the default fill-column. With prefix, unfill completely. This command does not modify the stored value of fill-column.
(defvar unpackaged/flex-fill-paragraph-column nil
"Last fill column used in command `unpackaged/flex-fill-paragraph'.")
;;;###autoload
(defun unpackaged/flex-fill-paragraph (&optional unfill)
"Fill paragraph, incrementing fill column each time this command is repeated.
When the command is called for the first time in a sequence,
unfill to the default `fill-column'. With prefix, unfill
completely. This command does not modify the stored value of
`fill-column'."
(interactive "P")
(let ((fill-column
(cond (unfill (setf unpackaged/flex-fill-paragraph-column nil)
most-positive-fixnum)
(t (setf unpackaged/flex-fill-paragraph-column
(if (equal last-command this-command)
(1+ (or unpackaged/flex-fill-paragraph-column
fill-column))
fill-column))))))
(fill-paragraph)
(message "Fill column: %s" fill-column)))iedit
These commands make iedit-mode a bit easier to use.
iedit-scoped
Call iedit-mode with function-local scope, or global scope if called with a universal prefix.
;;;###autoload
(defun unpackaged/iedit-scoped (orig-fn)
"Call `iedit-mode' with function-local scope, or global scope if called with a universal prefix."
(interactive)
(pcase-exhaustive current-prefix-arg
('nil (funcall orig-fn '(0)))
('(4) (funcall orig-fn))))
(advice-add #'iedit-mode :around #'unpackaged/iedit-scoped)iedit-or-flyspell
Toggle iedit-mode or correct previous misspelling with flyspell, depending on context.
With point in code or when iedit-mode is already active, toggle iedit-mode. With point in a comment or string, and when iedit-mode is not already active, auto-correct previous misspelled word with flyspell. Call this command a second time to choose a different correction.
;;;###autoload
(defun unpackaged/iedit-or-flyspell ()
"Toggle `iedit-mode' or correct previous misspelling with `flyspell', depending on context.
With point in code or when `iedit-mode' is already active, toggle
`iedit-mode'. With point in a comment or string, and when
`iedit-mode' is not already active, auto-correct previous
misspelled word with `flyspell'. Call this command a second time
to choose a different correction."
(interactive)
(if (or (bound-and-true-p iedit-mode)
(and (derived-mode-p 'prog-mode)
(not (or (nth 4 (syntax-ppss))
(nth 3 (syntax-ppss))))))
;; prog-mode is active and point is in a comment, string, or
;; already in iedit-mode
(call-interactively #'iedit-mode)
;; Not prog-mode or not in comment or string
(if (not (equal flyspell-previous-command this-command))
;; FIXME: This mostly works, but if there are two words on the
;; same line that are misspelled, it doesn't work quite right
;; when correcting the earlier word after correcting the later
;; one
;; First correction; autocorrect
(call-interactively 'flyspell-auto-correct-previous-word)
;; First correction was not wanted; use popup to choose
(progn
(save-excursion
(undo)) ; This doesn't move point, which I think may be the problem.
(flyspell-region (line-beginning-position) (line-end-position))
(call-interactively 'flyspell-correct-previous-word-generic)))))Sort sexps
Sort sexps in region. Comments stay with the code below.
;;;###autoload
(defun unpackaged/sort-sexps (beg end)
"Sort sexps in region.
Comments stay with the code below."
(interactive "r")
(cl-flet ((skip-whitespace () (while (looking-at (rx (1+ (or space "\n"))))
(goto-char (match-end 0))))
(skip-both () (while (cond ((or (nth 4 (syntax-ppss))
(ignore-errors
(save-excursion
(forward-char 1)
(nth 4 (syntax-ppss)))))
(forward-line 1))
((looking-at (rx (1+ (or space "\n"))))
(goto-char (match-end 0)))))))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char beg)
(skip-both)
(cl-destructuring-bind (sexps markers)
(cl-loop do (skip-whitespace)
for start = (point-marker)
for sexp = (ignore-errors
(read (current-buffer)))
for end = (point-marker)
while sexp
;; Collect the real string, then one used for sorting.
collect (cons (buffer-substring (marker-position start) (marker-position end))
(save-excursion
(goto-char (marker-position start))
(skip-both)
(buffer-substring (point) (marker-position end))))
into sexps
collect (cons start end)
into markers
finally return (list sexps markers))
(setq sexps (sort sexps (lambda (a b)
(string< (cdr a) (cdr b)))))
(cl-loop for (real . sort) in sexps
for (start . end) in markers
do (progn
(goto-char (marker-position start))
(insert-before-markers real)
(delete-region (point) (marker-position end)))))))))Regular expressions
query-replace-rx
Call query-replace-regexp, reading regexp in rx syntax. Automatically wraps in parens and adds seq to the beginning of the form.
;;;###autoload
(defun unpackaged/query-replace-rx (&rest _)
"Call `query-replace-regexp', reading regexp in `rx' syntax.
Automatically wraps in parens and adds `seq' to the beginning of
the form."
(interactive)
(cl-letf (((symbol-function #'query-replace-read-from) (lambda (&rest _)
(--> (read-string "rx form: ")
(concat "'(seq " it ")")
(read it)
(cadr it)
(rx-to-string it)))))
(call-interactively #'query-replace-regexp)))Version control
Magit
Improved magit-status command
Open a magit-status buffer and close the other window so only Magit is visible. If a file was visited in the buffer that was active when this command was called, go to its unstaged changes section.
;;;###autoload
(defun unpackaged/magit-status ()
"Open a `magit-status' buffer and close the other window so only Magit is visible.
If a file was visited in the buffer that was active when this
command was called, go to its unstaged changes section."
(interactive)
(let* ((buffer-file-path (when buffer-file-name
(file-relative-name buffer-file-name
(locate-dominating-file buffer-file-name ".git"))))
(section-ident `((file . ,buffer-file-path) (unstaged) (status))))
(magit-status)
(delete-other-windows)
(when buffer-file-path
(goto-char (point-min))
(cl-loop until (when (equal section-ident (magit-section-ident (magit-current-section)))
(magit-section-show (magit-current-section))
(recenter)
t)
do (condition-case nil
(magit-section-forward)
(error (cl-return (magit-status-goto-initial-section-1))))))))magit-log date headers
Add date headers to Magit log buffers.
Requires:
(defun unpackaged/magit-log--add-date-headers (&rest _ignore)
"Add date headers to Magit log buffers."
(when (derived-mode-p 'magit-log-mode)
(save-excursion
(ov-clear 'date-header t)
(goto-char (point-min))
(cl-loop with last-age
for this-age = (-some--> (ov-in 'before-string 'any (line-beginning-position) (line-end-position))
car
(overlay-get it 'before-string)
(get-text-property 0 'display it)
cadr
(s-match (rx (group (1+ digit) ; number
" "
(1+ (not blank))) ; unit
(1+ blank) eos)
it)
cadr)
do (when (and this-age
(not (equal this-age last-age)))
(ov (line-beginning-position) (line-beginning-position)
'after-string (propertize (concat " " this-age "\n")
'face 'magit-section-heading)
'date-header t)
(setq last-age this-age))
do (forward-line 1)
until (eobp)))))
(define-minor-mode unpackaged/magit-log-date-headers-mode
"Display date/time headers in `magit-log' buffers."
:global t
(if unpackaged/magit-log-date-headers-mode
(progn
;; Enable mode
(add-hook 'magit-post-refresh-hook #'unpackaged/magit-log--add-date-headers)
(advice-add #'magit-mode-setup :after #'unpackaged/magit-log--add-date-headers))
;; Disable mode
(remove-hook 'magit-post-refresh-hook #'unpackaged/magit-log--add-date-headers)
(advice-remove #'magit-mode-setup #'unpackaged/magit-log--add-date-headers)))This isn’t always perfect, because dates in a git commit log are not always in order (e.g. when commits are merged at a later date), but it’s often very helpful to visually group commits by their age.
Save buffer and show changes in Magit status
;;;###autoload
(defun unpackaged/magit-save-buffer-show-status ()
"Save buffer and show its changes in `magit-status'."
(interactive)
(save-buffer)
(unpackaged/magit-status))smerge-mode
Hydra
This configuration automatically activates a helpful smerge-mode hydra when a file containing merge conflicts is visited from a Magit diff section. You can manually activate the hydra with the command unpackaged/smerge-hydra/body. (Inspired by Kaushal Modi’s Emacs config.)
Requires:
See these screencasts comparing what it’s like to resolve the conflict with ediff and with this smerge-hydra.
(use-package smerge-mode
:after hydra
:config
(defhydra unpackaged/smerge-hydra
(:color pink :hint nil :post (smerge-auto-leave))
"
^Move^ ^Keep^ ^Diff^ ^Other^
^^-----------^^-------------------^^---------------------^^-------
_n_ext _b_ase _<_: upper/base _C_ombine
_p_rev _u_pper _=_: upper/lower _r_esolve
^^ _l_ower _>_: base/lower _k_ill current
^^ _a_ll _R_efine
^^ _RET_: current _E_diff
"
("n" smerge-next)
("p" smerge-prev)
("b" smerge-keep-base)
("u" smerge-keep-upper)
("l" smerge-keep-lower)
("a" smerge-keep-all)
("RET" smerge-keep-current)
("\C-m" smerge-keep-current)
("<" smerge-diff-base-upper)
("=" smerge-diff-upper-lower)
(">" smerge-diff-base-lower)
("R" smerge-refine)
("E" smerge-ediff)
("C" smerge-combine-with-next)
("r" smerge-resolve)
("k" smerge-kill-current)
("ZZ" (lambda ()
(interactive)
(save-buffer)
(bury-buffer))
"Save and bury buffer" :color blue)
("q" nil "cancel" :color blue))
:hook (magit-diff-visit-file . (lambda ()
(when smerge-mode
(unpackaged/smerge-hydra/body)))))Web
feed-for-url
Return ATOM or RSS feed URL for web page at URL. Interactively, insert the URL at point. PREFER may be atom (the default) or rss. When ALL is non-nil, return all feed URLs of all types; otherwise, return only one feed URL, preferring the preferred type.
Requires:
;;;###autoload
(cl-defun unpackaged/feed-for-url (url &key (prefer 'atom) (all nil))
"Return feed URL for web page at URL.
Interactively, insert the URL at point. PREFER may be
`atom' (the default) or `rss'. When ALL is non-nil, return all
feed URLs of all types; otherwise, return only one feed URL,
preferring the preferred type."
(interactive (list (org-web-tools--get-first-url)))
(require 'esxml-query)
(require 'org-web-tools)
(cl-flet ((feed-p (type)
;; Return t if TYPE appears to be an RSS/ATOM feed
(string-match-p (rx "application/" (or "rss" "atom") "+xml")
type)))
(let* ((preferred-type (format "application/%s+xml" (symbol-name prefer)))
(html (org-web-tools--get-url url))
(dom (with-temp-buffer
(insert html)
(libxml-parse-html-region (point-min) (point-max))))
(potential-feeds (esxml-query-all "link[rel=alternate]" dom))
(return (if all
;; Return all URLs
(cl-loop for (tag attrs) in potential-feeds
when (feed-p (alist-get 'type attrs))
collect (url-expand-file-name (alist-get 'href attrs) url))
(or
;; Return the first URL of preferred type
(cl-loop for (tag attrs) in potential-feeds
when (equal preferred-type (alist-get 'type attrs))
return (url-expand-file-name (alist-get 'href attrs) url))
;; Return the first URL of non-preferred type
(cl-loop for (tag attrs) in potential-feeds
when (feed-p (alist-get 'type attrs))
return (url-expand-file-name (alist-get 'href attrs) url))))))
(if (called-interactively-p)
(insert (if (listp return)
(s-join " " return)
return))
return))))License
GPLv3