Fetching latest commit…
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:
Contents
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:
(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))))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.
Convert Elisp docstrings to Org format
These functions convert Emacs Lisp docstrings to Org-formatted text, helpful for inserting into readme files.
(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 "\""))
(delete-char -1)))
(if (called-interactively-p)
(progn
(message it)
(kill-new it))
it))))
(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)))))))
(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:
(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)))))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))))
(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."
(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))))))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.
(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
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
(goto-char (point-min))
(ov-clear 'date-header t)
(--> (cl-loop for ov in (cdr (ov-all))
for margin-text = (-some--> (ov-val ov 'before-string)
(cadr (get-text-property 0 'display it)))
when margin-text
for age = (when (string-match (rx (group (1+ digit) ; number
" "
(1+ (not blank))) ; unit
(1+ blank) eol)
margin-text)
(match-string-no-properties 1 margin-text))
collect (cons age (ov-beg ov)))
(-group-by #'car it)
(--map (cons (car it) (-sort (-on #'< #'cdr) (cdr it)))
it)
(--map (cons (car it) (cdadr it)) it)
(cl-loop for (age . pos) in it
do (ov (1- pos) (1- pos)
'after-string (propertize (concat " " age "\n")
'face 'magit-section-heading)
'date-header t))))))
(add-hook 'magit-post-refresh-hook #'unpackaged/magit-log--add-date-headers)
(advice-add #'magit-mode-setup :after #'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.
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:
(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