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 [[http://github.com/alphapapa/unpackaged.el][repository]] or as [[http://alphapapa.github.io/unpackaged.el][HTML]].
Contributions welcome!
Functions in this file generally use these helper packages:
[[https://github.com/magnars/dash.el][dash.el]] (including ~dash-functional~)
Usage :PROPERTIES: :TOC: :ignore this :END:
There are two ways to use the code in this "unpackage":
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 [[https://framagit.org/steckerhalter/quelpa-use-package][quelpa-use-package]] like this:
(use-package unpackaged :quelpa (unpackaged :fetcher github :repo "alphapapa/unpackaged.el"))
;;; unpackaged.el --- Useful yet unsubstantial Emacs Lisp code -- lexical-binding: t; --
;; Copyright (C) 2018 Adam Porter
;; Author: Adam Porter adam@alphapapa.net ;; Keywords: convenience ;; URL: https://github.com/alphapapa/unpackaged.el ;; Package-Requires: ((emacs "25.1") (dash "2.13") (s "1.10.0") (org "9.0") (use-package "2.4"))
;;; License:
;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see https://www.gnu.org/licenses/.
;;; Commentary:
;; 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.
;;; Code:
;;;; Requirements
(require 'cl-lib) (require 'org)
(require 'dash) (require 's) (require 'use-package)
;;;; Customization
(defgroup unpackaged nil "Options for `unpackaged'." :group 'convenience)
Contents :noexport: :PROPERTIES: :TOC: :include siblings :ignore this :END: :CONTENTS:
[[#faces-fonts][Faces, fonts]]
[[#buffers][Buffers]]
[[#customization][Customization]]
[[#elfeed][Elfeed]]
[[#misc][Misc]]
[[#org][Org]]
[[#packages][Packages]]
[[#programming][Programming]]
[[#regular-expressions][Regular expressions]]
[[#version-control][Version control]]
[[#web][Web]]
Faces, fonts :faces:fonts:
;;; 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~, pressing Cancel to stop selecting fonts.
Requires:
[[images/font-compare.png]]
(require 'seq)
(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 withx-select-font', pressing Cancel to
stop selecting fonts."
(interactive (list (pcase (read-string "Text: ")
("" nil)
(else else))
;; x-select-font' calls quit() when Cancel is pressed, so we use ;;inhibit-quit', with-local-quit', andquit-flag' to avoid that.
(let ((inhibit-quit t))
(cl-loop for font = (with-local-quit
(x-select-font))
while font
collect font into fonts
finally do (setf quit-flag nil)
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))))
*** COMMENT Potential improvements :noexport: :PROPERTIES: :TOC: :ignore (this descendants) :END:
**** TODO Apply more face properties
e.g. weight, slant, etc.
**** TODO Default size setting
It might be helpful to use a larger size by default.
** ibuffer :ibuffer:
;;; ibuffer
*** Filter groups
These commands toggle and move filter groups.
(require 'ibuffer) (require 'ibuf-ext)
;;;###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' ordown'."
(ibuffer-kill-line)
(pcase-exhaustive direction
('down (ibuffer-forward-filter-group))
('up (ibuffer-backward-filter-group)))
(ibuffer-yank))
;;; Customization
** Expand all options' documentation
(defun unpackaged/custom-toggle-all-more-hide () "Toggle all \"More/Hide\" widgets in current buffer." (interactive) (widget-map-buttons (lambda (widget _) (pcase (widget-get widget :off) ("More" (widget-apply-action widget))) nil)))
** Set value of customization option at point
In =Customize= buffers, pressing =C-c C-c= offers to set all variables in the buffer, which isn't always what I want when point is on one option. This binds that key to a new function in =custom-field-keymap=, which is only active when point is on an editable field. The function sets only the current option.
(use-package cus-edit :general (:keymaps 'custom-field-keymap "C-c C-c" (defun unpackaged/custom-set-at-point () "Set current value of widget at point." (interactive) (cl-labels ((find-widget (widget property) (if (widget-get widget property) widget (find-widget (widget-get widget :parent) property)))) (when-let* ((widget (find-widget (widget-at) :custom-set))) (when (eq (widget-get widget :custom-state) 'modified) (widget-apply widget :custom-set)))))))
** Customize theme faces
Customize ~THEME~ with ~FACES~. Advises ~enable-theme~ with a function that customizes ~FACES~ when ~THEME~ is enabled. If ~THEME~ is already enabled, also applies faces immediately. Calls ~custom-theme-set-faces~, which see.
For example:
(unpackaged/customize-theme-faces 'doom-solarized-dark
(font-lock-builtin-face ((t :weight bold :foreground "#268bd2"))) (font-lock-comment-face ((t :weight bold :slant italic :foreground ,(doom-color 'comments))))
(org-list-dt ((t :weight bold))) (org-link ((t :inherit link :foreground ,(doom-color 'cyan) :weight normal)))
(org-date ((t :foreground ,(doom-color 'yellow) :weight bold))) (org-table ((t :foreground ,(doom-color 'green) :family "monospace")))
(org-block-begin-line ((t :weight bold :foreground ,(doom-color 'comments) :background ,(doom-color 'base2) :family "monospace"))) (org-meta-line ((t :weight bold :foreground ,(doom-color 'comments) :family "monospace"))))
;;;###autoload
(defun unpackaged/customize-theme-faces (theme &rest faces)
"Customize THEME with FACES.
Advises enable-theme' with a function that customizes FACES when THEME is enabled. If THEME is already enabled, also applies faces immediately. Callscustom-theme-set-faces', which see."
(declare (indent defun))
(when (member theme custom-enabled-themes)
;; Theme already enabled: apply faces now.
(let ((custom--inhibit-theme-enable nil))
(apply #'custom-theme-set-faces theme faces)))
(let ((fn-name (intern (concat "unpackaged/enable-theme-advice-for-" (symbol-name theme)))))
;; Apply advice for next time theme is enabled.
(fset fn-name
(lambda (enabled-theme)
(when (eq enabled-theme theme)
(let ((custom--inhibit-theme-enable nil))
(apply #'custom-theme-set-faces theme faces)))))
(advice-remove #'enable-theme fn-name)
(advice-add #'enable-theme :after fn-name)))
;;; Elfeed
** Filter hydra
Requires: [[https://github.com/jerrypnz/major-mode-hydra.el#pretty-hydra-define][pretty-hydra]]
This macro defines a [[https://github.com/jerrypnz/major-mode-hydra.el#pretty-hydra-define][pretty-hydra]] that makes it easy to toggle Elfeed filter components, which allows quickly building a custom filter with a few keystrokes. You can add your own favorite tokens to the hydra with your own keybindings, and it also provides completion for feeds and tags from the Elfeed database.
This animation shows the example hydra from the docstring:
[[images/elfeed-filter-hydra.gif]]
The example hydra:
(unpackaged/elfeed-search-view-hydra-define my/elfeed-search-view-hydra (:foreign-keys warn) ("Views" (("@" :complete-age "Date") ("d" nil)) "Status" (("su" "+unread")) "Feed" (("f TAB" :complete-feed "Choose") ("fE" "=Planet Emacslife" "Planet Emacslife")) "Tags" (("t TAB" :complete-tag "Choose") ("te" "+Emacs")) "" (("tn" "+news"))))
The macro and function:
(defvar elfeed-search-filter)
(cl-defmacro unpackaged/elfeed-search-view-hydra-define (name body views) "Define a pretty hydra named NAME with BODY and VIEWS. VIEWS is a plist: in it, each property is a string which becomes a column header in the hydra, and each value is a list of lists in this format: (KEY COMPONENT &optional LABEL).
The KEY is a key sequence passed to `kbd', like \"s\" or \"S TAB\". The COMPONENT is an Elfeed filter component, which may begin with \"+\" or \"=\", and in which spaces are automatically escaped as required by Elfeed. The LABEL, if present, is a string displayed next to the KEY; if absent, COMPONENT is displayed.
In the resulting hydra, when KEY is pressed, the COMPONENT is toggled in `elfeed-search-filter'. It is toggled between three states: normal, inverse, and absent. For example, the component \"+tag\" cycles between three states in the filter: \"+tag\", \"-tag\", and \"\". The appropriate inverse prefix is used according to the component's prefix (i.e. for \"=\", the inverse is \"~\", and for \"\" (a plain regexp), \"!\" is used).
These special components may be used to read choices from the Elfeed database with completion and toggle them:
:complete-age Completes and sets the age token.
:complete-feed Completes and toggles a feed token.
:complete-tag Completes and toggles a tag token.
nil Sets default filter.A complete example:
(unpackaged/elfeed-search-view-hydra-define my/elfeed-search-view-hydra
(:foreign-keys warn)
(\"Views\"
((\"@\" :complete-age \"Date\")
(\"d\" nil))
\"Status\"
((\"su\" \"+unread\"))
\"Feed\"
((\"f TAB\" :complete-feed \"Choose\")
(\"fE\" \"=Planet Emacslife\" \"Planet Emacslife\"))
\"Tags\"
((\"t TAB\" :complete-tag \"Choose\")
(\"te\" \"+Emacs\"))
\"\"
((\"tn\" \"+news\"))))"
(declare (indent defun))
(cl-labels ((escape-spaces (string)
;; Return STRING with spaces escaped with "\s-". Necessary
;; because Elfeed treats all literal spaces as separating tokens.
(replace-regexp-in-string (rx space) "\\s-" string t t)))
(let* ((completion-fns
(list (cons :complete-age
(lambda ()
(interactive)
(save-match-data
(let* ((date-regexp (rx (group (or bos blank) "@" (1+ digit) (1+ (not blank)))))
(date-tag (when (string-match date-regexp elfeed-search-filter)
(match-string 1 elfeed-search-filter))))
(elfeed-search-set-filter
(replace-regexp-in-string date-regexp (read-string "Date: " date-tag)
elfeed-search-filter t t))))))
(cons :complete-feed
'(concat "=" (replace-regexp-in-string
(rx space) "\\s-"
(->> (hash-table-values elfeed-db-feeds)
(--map (elfeed-meta it :title))
(completing-read "Feed: ")
regexp-quote) t t)))
(cons :complete-tag
'(concat "+" (completing-read "Tag: " (elfeed-db-get-all-tags))))))
(body (append '(:title elfeed-search-filter :color pink :hint t :quit-key "q")
body))
(heads (cl-loop for (heading views) on views by #'cddr
collect heading
collect (cl-loop for (key component label) in views
collect
`(,key
,(cl-typecase component
((and function (not null))
;; I don't understand why nil matches
;; (or lambda function), but it does,
;; so we have to account for it. See
;; (info-lookup-symbol 'cl-typep).
`(funcall ,component))
(string
`(elfeed-search-set-filter
(unpackaged/elfeed-search-filter-toggle-component
elfeed-search-filter ,(escape-spaces component))))
(otherwise
`(elfeed-search-set-filter
,(when component
`(unpackaged/elfeed-search-filter-toggle-component
elfeed-search-filter ,component)))))
,(or label component "Default"))))))
;; I am so glad I discovered `cl-sublis'. I tried several variations of `cl-labels' and
;; `cl-macrolet' and `cl-symbol-macrolet', but this is the only way that has worked.
(setf heads (cl-sublis completion-fns heads))
`(pretty-hydra-define ,name ,body
,heads))))(cl-defun unpackaged/elfeed-search-filter-toggle-component (string component)
"Return STRING (which should be elfeed-search-filter') having toggled COMPONENT. Tries to intelligently handle components based on their prefix: +tag, =feed, regexp." (save-match-data (cl-labels ((toggle (component +prefix -prefix string) (let ((+pat (rx-to-string(seq (or bos blank)
(group ,+prefix ,component)
(or eos blank))))
(-pat (rx-to-string (seq (group (or bos (1+ blank)) ,-prefix ,component) (or eos blank))))) ;; TODO: In newer Emacs versions, therx' pattern literal' ;; evaluates at runtime inpcase' expressions.
(pcase string
((pred (string-match +pat)) (rm (concat -prefix component) string))
((pred (string-match -pat)) (rm "" string))
( (concat string " " +prefix component)))))
(rm (new string) (replace-match new t t string 1)))
(pcase component
((rx bos "+" (group (1+ anything)))
(toggle (match-string 1 component) "+" "-" string))
((rx bos "=" (group (1+ anything)))
(toggle (match-string 1 component) "=" "~" string))
( (toggle component "" "!" string))))))
Code used to help maintain this document. (Note: These links don't work in GitHub's renderer.)
[[Convert Elisp docstrings to Org format][Convert Elisp docstrings to Org format]]
Misc
;;; Misc
** Define a "chooser" command
This macro defines a "chooser" command, which allows the user to use completion to choose a lambda function to run. It's helpful for grouping related functions together, or swapping between choices which can be set from Lisp code.
(defmacro unpackaged/define-chooser (name &rest choices)
"Define a chooser command NAME offering CHOICES.
Each of CHOICES should be a list, the first of which is the
choice's name, and the rest of which is its body forms."
(declare (indent defun))
;; Avoid redefining existing, non-chooser functions.
(cl-assert (or (not (fboundp name))
(get name :unpackaged/define-chooser)))
(let ((choice-names (mapcar #'car choices))
(choice-list (--map (cons (car it) (lambda (&rest args) ,@(cdr it))) choices)) (prompt (format "Choose %s: " name)) (docstring (concat "Choose between: " (s-join ", " choice-names)))) (progn
(defun ,name ()
,docstring
(interactive)
(let ((choice-name (completing-read ,prompt ',choice-names)))
(funcall (alist-get choice-name ',choice-list nil nil #'equal))))
(put ',name :unpackaged/define-chooser t))))
This example shows using it to set [[https://github.com/alphapapa/prism.el][prism.el]] themes by calling =prism-set-colors= in each choice.
(unpackaged/define-chooser ap/prism-theme ("Keen" (prism-set-colors :num 16 :local (pcase current-prefix-arg ('(16) 'reset) ( current-prefix-arg)) :desaturations (cl-loop for i from 0 below 16 collect ( i 2.5)) :lightens (cl-loop for i from 0 below 16 collect ( i 2.5)) :colors (list "sandy brown" "dodgerblue" "medium sea green") :comments-fn (lambda (color) (prism-blend color (face-attribute 'font-lock-comment-face :foreground) 0.25)) :strings-fn (lambda (color) (prism-blend color "white" 0.5)))) ("Solarized: rainbow" (prism-set-colors :num 24 :local (pcase current-prefix-arg ('(16) 'reset) ( current-prefix-arg)) :lightens '(5 15 25) :colors (solarized-with-color-variables 'dark (list red orange yellow green blue cyan violet magenta)) :comments-fn (lambda (color) (--> color (color-desaturate-name it 50))) :strings-fn (lambda (color) (prism-blend color "white" 0.5)))) ("Solarized: rainbow inverted" (prism-set-colors :num 24 :local (pcase current-prefix-arg ('(16) 'reset) (_ current-prefix-arg)) :lightens '(5 15 25) :colors (solarized-with-color-variables 'dark (nreverse (list red orange yellow green blue cyan violet magenta))) :comments-fn (lambda (color) (--> color (color-desaturate-name it 50))) :strings-fn (lambda (color) (prism-blend color "white" 0.5)))))
** Obfuscate buffer text with /lorem ipsum/ words
When taking a screenshot, one may not want to reveal the text that is in it. Rather than editing the screenshot to hide the text, one can use this command to temporarily overlay text in a buffer with /lorem ipsum/ words, which present a similar appearance without any meaning.
Requires:
[[images/lorem-ipsum-overlay.png]]
(defcustom unpackaged/lorem-ipsum-overlay-exclude nil "List of regexps to exclude from `unpackaged/lorem-ipsum-overlay'." :type '(repeat regexp))
;;;###autoload (cl-defun unpackaged/lorem-ipsum-overlay (&key replace-p use-map-p) "Overlay all text in current buffer with \"lorem ipsum\" text. When called again, remove overlays. Useful for taking screenshots without revealing buffer contents.
If REPLACE-P is non-nil (interactively, with prefix and prompt), replace buffer contents rather than overlaying them. When a buffer is very large and would have so many overlays that performance would be prohibitively slow, you may replace the buffer contents instead. (Of course, be careful about saving the buffer after replacing its contents.)
If USE-MAP-P is non-nil (interactively, with prefix and prompt), all instances of a real word are replaced with the same word; otherwise, each instance of a real word is replaced with a random word (further obscuring the text).
Each piece of non-whitespace text in the buffer is compared with regexps in `unpackaged/lorem-ipsum-overlay-exclude', and ones that match are not overlaid. Note that the regexps are compared against the entire non-whitespace token, up-to and including the preceding whitespace, but only the alphabetic part of the token is overlaid. For example, in an Org buffer, a line that starts with:
,#+TITLE: unpackaged.elcould be matched against the exclude regexp (in `rx' syntax):
(rx (or bol bos blank) \"#+\" (1+ alnum) \":\" (or eol eos blank))And the line would be overlaid like:
,#+TITLE: parturient.et"
(interactive (when current-prefix-arg
(list :replace-p (yes-or-no-p "Replace contents (or just overlay)? ")
:use-map-p (yes-or-no-p "Map words (or be completely random)? "))))
(require 'lorem-ipsum)
(let ((ovs (overlays-in (point-min) (point-max))))
(if (cl-loop for ov in ovs
thereis (overlay-get ov :lorem-ipsum-overlay))
;; Remove overlays.
(dolist (ov ovs)
(when (overlay-get ov :lorem-ipsum-overlay)
(delete-overlay ov)))
;; Add overlays.
(let ((lorem-ipsum-words (--> lorem-ipsum-text
(-flatten it) (apply #'concat it)
(split-string it (rx (or space punct)) 'omit-nulls)))
(case-fold-search nil)
(map (make-hash-table :test #'equal)))
(cl-labels ((overlay-group (group)
(let* ((beg (match-beginning group))
(end (match-end group))
(replacement-word (if use-map-p
(lorem-word* (match-string-no-properties group))
(lorem-word (match-string-no-properties group))))
(ov (make-overlay beg end)))
(when replacement-word
(overlay-put ov :lorem-ipsum-overlay t)
(overlay-put ov 'display replacement-word))))
(replace-group (group)
(let* ((beg (match-beginning group))
(end (match-end group))
(replacement-word (if use-map-p
(lorem-word* (match-string-no-properties group))
(lorem-word (match-string-no-properties group)))))
(when replacement-word
(setf (buffer-substring beg end) replacement-word))))
(lorem-word (word)
(if-let* ((matches (lorem-matches (length word))))
(apply-case word (downcase (seq-random-elt matches)))
;; Word too long: compose one.
(apply-case word (downcase (compose-word (length word))))))
(lorem-word* (word)
(or (gethash word map)
(puthash word
(if-let ((matches (lorem-matches (length word))))
(apply-case word (downcase (seq-random-elt matches)))
;; Word too long: compose one.
(apply-case word (downcase (compose-word (length word)))))
map)))
(lorem-matches (length &optional (comparator #'=))
(cl-loop for liw in lorem-ipsum-words
when (funcall comparator (length liw) length)
collect liw))
(apply-case (source target)
(cl-loop for sc across-ref source
for tc across-ref target
when (not (string-match-p (rx lower) (char-to-string sc)))
do (setf tc (string-to-char (upcase (char-to-string tc)))))
target)
(compose-word (length)
(cl-loop while (> length 0)
for word = (seq-random-elt (lorem-matches length #'<=))
concat word
do (cl-decf length (length word)))))
(save-excursion
(goto-char (point-min))
(while (re-search-forward (rx (group (1+ (or bol bos blank (not alpha)))
(0+ (not (any alpha blank)))
(group (1+ alpha))
(0+ (not (any alpha blank)))))
nil t)
(unless (cl-member (match-string-no-properties 0) unpackaged/lorem-ipsum-overlay-exclude
:test (lambda (string regexp)
(string-match-p regexp string)))
(if replace-p
(replace-group 2)
(overlay-group 2)))
(goto-char (match-end 2)))))))))** Track metadata from MPRIS-supporting media player :DBus:
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.
(eval-when-compile (require 'dbus))
(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) "")))))
Code for [[https://orgmode.org/][Org Mode]].
;;; Org
** Agenda :agenda:
*** Agenda for subtree or region
Display an agenda view for the current subtree or region. With prefix, display only ~TODO~-keyword items.
(defvar org-agenda-overriding-header) (defvar org-agenda-sorting-strategy) (defvar org-agenda-restrict) (defvar org-agenda-restrict-begin) (defvar org-agenda-restrict-end)
;;;###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' ;; aroundorg-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 for outline path
Show an agenda restricted to subtree at ~OUTLINE-PATH~. ~FILE~ may be a filename to search in, or nil to look in the current buffer. If ~ONLY-TODOS~ is non-nil, show only to-do items. ~OUTLINE-PATH~ is a list of strings which are outline headings. See function ~org-find-olp~.
(defun unpackaged/org-agenda-olp (outline-path &optional file only-todos) "Show an agenda restricted to subtree at OUTLINE-PATH. FILE may be a filename to search in, or nil to look in the current buffer. If ONLY-TODOS is non-nil, show only to-do items. OUTLINE-PATH is a list of strings which are outline headings. See function `org-find-olp'." (when file (push file outline-path)) (let ((marker (org-find-olp outline-path (not file)))) (with-current-buffer (marker-buffer marker) (org-with-wide-buffer (goto-char marker) (unpackaged/org-agenda-current-subtree-or-region only-todos)))))
*** Agenda previews
/Before:/
[[images/org-agenda-preview-before.png]]
/After:/
[[images/org-agenda-preview-after.png]]
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 :meta: :PROPERTIES: :ID: b86d14ff-b87c-4e2a-a513-067c0a5d3490 :END:
These functions convert Emacs Lisp code and docstrings to Org-formatted text, helpful for inserting into readme files (like this one).
;;;###autoload (cl-defun unpackaged/package-org-docs (&optional (package (unpackaged/buffer-provides))) "Return documentation about PACKAGE as an Org string. Interactively, place on kill ring." (interactive) (let ((commands (--map (cons it (if (documentation it) (unpackaged/docstring-to-org (documentation it)) "Undocumented.")) (-sort (-on #'string< #'symbol-name) (unpackaged/package-commands package)))) (functions (seq-difference (--map (cons it (if (documentation it) (unpackaged/docstring-to-org (documentation it)) "Undocumented.")) (-sort (-on #'string< #'symbol-name) (unpackaged/package-functions package))) commands)) (commands-string (when commands (->> commands (--map (format "+ ~%s%s~ :: %s" (car it) (--when-let (documentation (car it)) (concat " (" (unpackaged/docstring-function-args it) ")")) (cdr it))) (s-join "\n") (format " Commands\n\n%s")))) (functions-string (when functions (->> functions (--map (format "+ ~%s%s~ :: %s" (car it) (--when-let (documentation (car it)) (concat " (" (unpackaged/docstring-function-args it) ")")) (cdr it))) (s-join "\n") (format "* Functions\n\n%s")))) (string (s-join "\n\n" (list commands-string functions-string)))) (if (called-interactively-p 'any) (progn (kill-new string) (message "Documentation stored in kill ring")) string)))
(cl-defun unpackaged/package-commands (&optional (package (unpackaged/buffer-provides))) "Return list of command symbols in PACKAGE, or current buffer's package." (let* ((functions (unpackaged/package-functions package))) (-select #'commandp functions)))
(cl-defun unpackaged/package-functions (&optional (package (unpackaged/buffer-provides))) "Return list of functions defined in PACKAGE, or current buffer's package." (let* ((prefix (symbol-name package)) (symbols)) (mapatoms (lambda (symbol) (when (string-prefix-p prefix (symbol-name symbol)) (push symbol symbols)))) (->> symbols (-select #'fboundp) (--select (not (string-suffix-p "--cmacro" (symbol-name it)))))))
(cl-defun unpackaged/buffer-provides (&optional (buffer (current-buffer))) "Return symbol that Emacs package in BUFFER provides." ;; I couldn't find an existing function that does this, but this is simple enough. (with-current-buffer buffer (save-excursion (goto-char (point-max)) (re-search-backward (rx bol "(provide '" (group (1+ (not (any ")")))) ")")) (intern (match-string 1)))))
;;;###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
(progn
;; Remove end-of-string function argument list
(goto-char (point-max))
(when (re-search-backward (rx "\n\n" "(fn " (group (1+ not-newline)) ")" eos) nil t)
(replace-match "" t t)))
(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))
(while (re-search-forward "\n" nil t)
(replace-match "\n " t t))
(when (looking-at "\"")
(delete-char 1))
(when (progn
(goto-char (point-max))
(looking-back "\"" nil))
(delete-char -1))
(while (re-search-forward (rx bol (group (>= 2 " ")) (group (1+ (not space)) (1+ not-newline))) nil t)
;; Indented code samples, by two or more spaces
(replace-match (concat (match-string 1) "~" (match-string 2) "~"))))
(s-trim it)
(if (called-interactively-p 'interactive)
(progn
(message it)
(kill-new it))
it))))
(defun unpackaged/docstring-function-args (docstring) "Return function args parsed from DOCSTRING. DOCSTRING should be like one returned by function `documentation', which typically has function arguments on the last line." (when (string-match (rx "\n\n" "(fn " (group (1+ not-newline)) ")" eos) docstring) (match-string 1 docstring)))
;;;###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+ (or 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 (syntax symbol)))) (or "’" "'")) nil t)
(replace-match (concat "~" (match-string 1) "~") t)))))
*** COMMENT Tasks
**** MAYBE Publish these on emacs-package-dev-handbook instead
Not sure which place they best belong, but they should at least be linked in both.
** 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 (&optional 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 thatorg-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: