;;; acdw.el --- miscellaneous -*- lexical-binding: t; coding: utf-8-unix -*-
;; Author: Case Duckworth <(rot13-string "npqj@npqj.arg")>
;; Created: Sometime during Covid-19, 2020
;; Keywords: configuration
;; URL: https://tildegit.org/acdw/emacs
;; This file is NOT part of GNU Emacs.
;;; License:
;; Everyone is permitted to do whatever with this software, without
;; limitation. This software comes without any warranty whatsoever,
;; but with two pieces of advice:
;; - Don't hurt yourself.
;; - Make good choices.
;;; Commentary:
;; `acdw.el' contains `acdw/map', its mode, and assorted ease-of-life
;; functions for me, acdw.
;;; Code:
(require 'cl-lib)
(require 'auth-source)
(require 'recentf)
;;; Variables
(defconst acdw/system
(pcase system-type
('gnu/linux :home)
((or 'msdos 'windows-nt) :work)
(_ :other))
"Which computer system is currently being used.")
(defmacro acdw/system (&rest args)
"Macro for interfacing, depending on ARGS, with symbol `acdw/system'.
When called without arguments, it returns symbol `acdw/system'. When
called with one (symbol) argument, it returns (eq acdw/system
ARG). When called with multiple arguments or a list, it returns
`pcase' over each argument."
(cond
((null args) acdw/system)
((atom (car args))
`(when (eq acdw/system ,(car args))
,(car args)))
(t
`(pcase acdw/system
,@args))))
;;; Utility functions
;; I don't prefix these because ... reasons. Honestly I probably should prefix
;; them.
(defun truncate-string (len str &optional ellipsis)
"If STR is longer than LEN, cut it down and add ELLIPSIS to the end.
When not specified, ELLIPSIS defaults to '...'."
(declare (pure t) (side-effect-free t))
(unless ellipsis
(setq ellipsis "..."))
(if (> (length str) len)
(format "%s%s" (substring str 0 (- len (length ellipsis))) ellipsis)
str))
;; Why isn't this a thing???
(defmacro fbound-and-true-p (func)
"Return the value of function FUNC if it is bound, else nil."
`(and (fboundp ,func) ,func))
(defmacro when-unfocused (name &rest forms)
"Define a function NAME, executing FORMS, for when Emacs is unfocused."
(declare (indent 1))
(let ((func-name (intern (concat "when-unfocused-" (symbol-name name)))))
`(progn
(defun ,func-name () "Defined by `when-unfocused'."
(when (seq-every-p #'null
(mapcar #'frame-focus-state (frame-list)))
,@forms))
(add-function :after after-focus-change-function #',func-name))))
(defmacro with-eval-after-loads (features &rest body)
"Execute BODY after FEATURES are loaded.
This macro simplifies `with-eval-after-load' for multiple nested
features."
(declare (indent 1)
(debug (form def-body)))
(unless (listp features)
(setq features (list features)))
(if (null features)
(macroexp-progn body)
(let* ((this (car features))
(rest (cdr features)))
`(with-eval-after-load ',this
(with-eval-after-loads ,rest ,@body)))))
(defmacro with-message (message &rest body)
"Execute BODY, messaging 'MESSAGE...' before and 'MESSAGE... Done.' after."
(declare (indent 1))
;; Wrap a progn inside a prog1 to return the return value of the body.
`(prog1
(progn (message "%s..." ,message)
,@body)
(message "%s... Done." ,message)))
(defun clone-buffer-write-file (filename &optional confirm)
"Clone current buffer to a file named FILENAME and switch.
FILENAME and CONFIRM are passed directly to `write-file'."
(interactive ; stolen from `write-file'
(list (if buffer-file-name
(read-file-name "Write file: "
nil nil nil nil)
(read-file-name "Write file: " default-directory
(expand-file-name
(file-name-nondirectory (buffer-name))
default-directory)
nil nil))
(not current-prefix-arg)))
(let ((buf (clone-buffer nil nil)))
(with-current-buffer buf
(write-file filename confirm))
(switch-to-buffer buf)))
;; https://old.reddit.com/r/emacs/comments/pjwkts
(defun acdw/goto-last-row ()
"Move point to last row of buffer, but save the column."
(interactive)
(let ((col (current-column)))
(goto-char (point-max))
(move-to-column col t)))
(defun acdw/goto-first-row ()
"Move point to first row of buffer, but save the column."
(interactive)
(let ((col (current-column)))
(goto-char (point-min))
(move-to-column col t)))
(defun dos2unix (buffer)
"Replace \r\n with \n in BUFFER."
(interactive "*b")
(save-excursion
(with-current-buffer buffer
(goto-char (point-min))
(while (search-forward (string ?\C-m ?\C-j) nil t)
(replace-match (string ?\C-j) nil t)))))
(defun expand-file-name-exists-p (&rest args)
"Return `expand-file-name' ARGS if it exists, or nil."
(let ((file (apply #'expand-file-name args)))
(if (file-exists-p file)
file
nil)))
(defun kill-region-or-backward-word (arg)
"If region is active, kill; otherwise kill word backward with ARG."
(interactive "p")
(if (region-active-p)
(kill-region (region-beginning) (region-end))
(if (bound-and-true-p paredit-mode)
(paredit-backward-kill-word)
(backward-kill-word arg))))
(defun unfill-buffer (&optional buffer-or-name)
"Unfill entire contents of BUFFER-OR-NAME."
(with-current-buffer (or buffer-or-name (current-buffer))
(save-excursion
(save-restriction
(unfill-region (point-min) (point-max))))))
(defun waterfall-list (car list rest)
"Cons CAR with each element in LIST in a waterfall fashion, end with REST.
For use with the `with-eval-after-loads' function."
(cond ((atom list) `(,car ',list ,@rest))
((= 1 (length list)) `(,car ',(car list) ,@rest))
(t
`(,car ',(car list)
,(waterfall-list car (cdr list) rest)))))
;;; Comment-or-uncomment-sexp
;; from https://endlessparentheses.com/a-comment-or-uncomment-sexp-command.html
(defun uncomment-sexp (&optional n)
"Uncomment N sexps around point."
(interactive "P")
(let* ((initial-point (point-marker))
(inhibit-field-text-motion t)
(p)
(end (save-excursion
(when (elt (syntax-ppss) 4)
(re-search-backward comment-start-skip
(line-beginning-position)
t))
(setq p (point-marker))
(comment-forward (point-max))
(point-marker)))
(beg (save-excursion
(forward-line 0)
(while (and (not (bobp))
(= end (save-excursion
(comment-forward (point-max))
(point))))
(forward-line -1))
(goto-char (line-end-position))
(re-search-backward comment-start-skip
(line-beginning-position)
t)
(ignore-errors
(while (looking-at-p comment-start-skip)
(forward-char -1)))
(point-marker))))
(unless (= beg end)
(uncomment-region beg end)
(goto-char p)
;; Indentify the "top-level" sexp inside the comment.
(while (and (ignore-errors (backward-up-list) t)
(>= (point) beg))
(skip-chars-backward (rx (syntax expression-prefix)))
(setq p (point-marker)))
;; Re-comment everything before it.
(ignore-errors
(comment-region beg p))
;; And everything after it.
(goto-char p)
(forward-sexp (or n 1))
(skip-chars-forward "\r\n[:blank:]")
(if (< (point) end)
(ignore-errors
(comment-region (point) end))
;; If this is a closing delimiter, pull it up.
(goto-char end)
(skip-chars-forward "\r\n[:blank:]")
(when (eq 5 (car (syntax-after (point))))
(delete-indentation))))
;; Without a prefix, it's more useful to leave point where
;; it was.
(unless n
(goto-char initial-point))))
(defun comment-sexp--raw ()
"Comment the sexp at point or ahead of point."
(pcase (or (bounds-of-thing-at-point 'sexp)
(save-excursion
(skip-chars-forward "\r\n[:blank:]")
(bounds-of-thing-at-point 'sexp)))
(`(,l . ,r)
(goto-char r)
(skip-chars-forward "\r\n[:blank:]")
(save-excursion
(comment-region l r))
(skip-chars-forward "\r\n[:blank:]"))))
(defun comment-or-uncomment-sexp (&optional n)
"Comment the sexp at point and move past it.
If already inside (or before) a comment, uncomment instead.
With a prefix argument N, (un)comment that many sexps."
(interactive "P")
(if (or (elt (syntax-ppss) 4)
(< (save-excursion
(skip-chars-forward "\r\n[:blank:]")
(point))
(save-excursion
(comment-forward 1)
(point))))
(uncomment-sexp n)
(dotimes (_ (or n 1))
(comment-sexp--raw))))
;;; Sort sexps
;; from https://github.com/alphapapa/unpackaged.el#sort-sexps
;; and https://github.com/alphapapa/unpackaged.el/issues/20
(defun sort-sexps (beg end &optional key-fn sort-fn)
"Sort sexps between BEG and END.
Comments stay with the code below.
Optional argument KEY-FN will determine where in each sexp to
start sorting. e.g. (lambda (sexp) (symbol-name (car sexp)))
Optional argument SORT-FN will determine how to sort two sexps'
strings. It's passed to `sort'. By default, it sorts the sexps
with `string<' starting with the key determined by KEY-FN."
(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)
(if key-fn
(funcall key-fn sexp)
(buffer-substring
(point)
(marker-position end)))))
into sexps
collect (cons start end)
into markers
finally return (list sexps markers))
(setq sexps (sort sexps (if sort-fn sort-fn
(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)))))))))
(defun acdw/sort-setups ()
"Sort `setup' forms in the current buffer.
Actually sorts all forms, but based on the logic of `setup'.
In short, DO NOT USE THIS FUNCTION!!!"
(save-excursion
(sort-sexps
(point-min) (point-max)
;; Key function
nil
;; Sort function
(lambda (s1 s2) ; oh god, this is worse.
(let* ((s1 (cdr s1)) (s2 (cdr s2)) ; for the strings themselves
(require-regexp (rx bos (* nonl) ":require"))
(straight-regexp (rx bos (* nonl) ":straight"))
(s1-require (string-match require-regexp s1))
(s2-require (string-match require-regexp s2))
(s1-straight (string-match straight-regexp s1))
(s2-straight (string-match straight-regexp s2)))
(cond
;; Straight forms require some weirdness
((and s1-straight s2-straight)
(let* ((r (rx ":straight" (? "-if") (* space) (? "(")))
(s1 (replace-regexp-in-string r "" s1))
(s2 (replace-regexp-in-string r "" s2)))
(string< s1 s2)))
;; requires should go first
((and s1-require (not s2-require)) t)
((and (not s1-require) s2-require) nil)
;; straights should go last
((and s1-straight (not s2-straight)) nil)
((and (not s1-straight) s2-straight) t)
;; else, just sort em.
(t (string< s1 s2))))))))
;;; Emacs configuration functions
(defun emacs-git-pull-config (&optional remote branch)
"`git-pull' Emacs' configuration from REMOTE and BRANCH.
REMOTE defaults to 'origin', BRANCH to 'main'."
(let ((remote (or remote "origin"))
(branch (or branch "main")))
(with-message (format "Pulling Emacs's configuration from %s" branch)
(shell-command (concat "git -C "
"\"" (expand-file-name user-emacs-directory) "\""
" pull " remote " " branch)
(get-buffer-create "*emacs-git-pull-config-output*")
(get-buffer-create "*emacs-git-pull-config-error*")))))
(defun emacs-reload (&optional git-pull-first)
"Reload Emacs's configuration files.
With a prefix argument GIT-PULL-FIRST, run git pull on the repo
first."
(interactive "P")
(when git-pull-first
(emacs-git-pull-config))
(let ((init-files (append
;; Load lisp libraries first, in case their functionality
;; is used by {early-,}init.el
(let* ((dir (expand-file-name "lisp/"
user-emacs-directory))
(full-name (lambda (f)
(concat
(file-name-as-directory dir) f))))
(mapcar full-name (directory-files dir nil "\\.el\\'")))
;; Load regular init files
(list (locate-user-emacs-file "early-init.el")
(locate-user-emacs-file "init.el" ".emacs"))))
(debug-on-error t))
(with-message "Saving init files"
(save-some-buffers :no-confirm (lambda () (member (buffer-file-name)
init-files))))
(dolist (file init-files)
(with-message (format "Loading %s" file)
(when (file-exists-p file)
(load-file file))))))
;;; Specialized functions
(defun acdw/copy-region-plain (beg end)
"Copy a region from BEG to END to clipboard, removing all Org formatting."
(interactive "r")
(let ((s (buffer-substring-no-properties beg end))
(extracted-heading (when (derived-mode-p 'org-mode)
(acdw/org-extract-heading-text))))
(with-temp-buffer
(insert s)
(let ((sentence-end-double-space nil))
;; Remove org stuff
(when extracted-heading ; Replace org heading with plaintext
(goto-char (point-min))
(kill-line)
(insert extracted-heading))
;; Delete property drawers
(replace-regexp org-property-drawer-re "")
;; Delete logbook drawers
(replace-regexp org-logbook-drawer-re "")
;; Replace list items with their contents, paragraphed
(replace-regexp org-list-full-item-re "
\4")
;; Delete comment lines
(replace-regexp (concat org-comment-regexp ".*$") "")
;; Re-fill text for clipboard
(unfill-region (point-min) (point-max))
(flush-lines "^$" (point-min) (point-max)))
;; Copy buffer
(copy-region-as-kill (point-min) (point-max))))
(when (called-interactively-p 'interactive)
(indicate-copied-region))
(setq deactivate-mark t)
nil)
;; https://emacs.stackexchange.com/questions/36366/
(defun html-body-id-filter (output backend info)
"Remove random ID attributes generated by Org."
(when (eq backend 'html)
(replace-regexp-in-string
" id=\"[[:alpha:]-]*org[[:alnum:]]\\{7\\}\""
""
output t)))
(defun html-body-div-filter (output backend info)
"Remove wrapping divs generated by Org."
(when (eq backend 'html)
(replace-regexp-in-string
"]*>\n*" ""
output t)))
(defun org-demote-headings (backend)
(while (/= (point) (point-max))
(org-next-visible-heading 1)
(org-demote-subtree)))
(defun acdw/org-export-copy-html ()
"Copy a tree as HTML."
(interactive)
(require 'ox-html)
(org-export-with-buffer-copy
;; (add-hook 'org-export-before-parsing-hook #'org-demote-headings nil t)
(let ((extracted-heading (acdw/org-extract-heading-text))
(org-export-show-temporary-export-buffer nil)
(org-export-filter-final-output-functions
'(html-body-id-filter html-body-div-filter))
(org-export-with-smart-quotes nil)
(org-export-smart-quotes-alist nil))
(insert "* ORG IS STUPID SOMETIMES\n")
(goto-char (point-min))
(org-html-export-as-html nil t nil t)
(with-current-buffer "*Org HTML Export*"
(goto-char (point-min))
(replace-regexp ".*
" "")
(insert "" extracted-heading "
")
(flush-lines "^$" (point-min) (point-max))
(let ((sentence-end-double-space nil))
(unfill-region (point-min) (point-max)))
(replace-regexp " +" "" nil (point-min) (point-max))
(replace-regexp " +
" "" nil (point-min) (point-max))
(copy-region-as-kill (point-min) (point-max)))))
(when (called-interactively-p 'interactive)
(indicate-copied-region))
(setq deactivate-mark t)
nil)
(defun acdw/org-export-copy ()
"copy a tree"
(interactive)
(require 'ox-ascii)
(let ((extracted-heading (acdw/org-extract-heading-text)))
;; Export to ASCII - not async, subtree only, visible-only, body-only
(let ((org-export-show-temporary-export-buffer nil))
(org-ascii-export-as-ascii nil t nil t))
(with-current-buffer "*Org ASCII Export*"
(goto-char (point-min))
(insert extracted-heading)
(newline 2)
(replace-regexp org-list-full-item-re "
\4")
(let ((sentence-end-double-space nil))
(unfill-region (point-min) (point-max)))
(flush-lines "^$" (point-min) (point-max))
(copy-region-as-kill (point-min) (point-max)))
(when (called-interactively-p 'interactive)
(indicate-copied-region))
(setq deactivate-mark t)
nil))
(defun acdw/org-extract-heading-text ()
"Extract the heading text from an `org-mode' heading."
(let ((heading (org-no-properties (org-get-heading t t t t))))
(message
(replace-regexp-in-string org-link-bracket-re
(lambda (match)
(match-string-no-properties 2 match))
heading))))
(defun acdw/sync-dir (&optional file make-directory)
"Return FILE from ~/Sync.
Optional argument MAKE-DIRECTORY makes the directory.
Logic is as in `acdw/dir', which see."
(let ((dir (expand-file-name (convert-standard-filename "~/Sync/"))))
(if file
(let ((file-name (expand-file-name (convert-standard-filename file)
dir)))
(when make-directory
(make-directory (file-name-directory file-name) 'parents))
file-name)
dir)))
(defun acdw/dir (&optional file make-directory)
"Place Emacs files in one place.
If called without parameters, `acdw/dir' expands to
~/.emacs.d/var or similar. If called with FILE, `acdw/dir'
expands FILE to ~/.emacs.d/var, optionally making its directory
if MAKE-DIRECTORY is non-nil."
(let ((dir (expand-file-name (convert-standard-filename "var/")
user-emacs-directory)))
(if file
(let ((file-name (expand-file-name (convert-standard-filename file)
dir)))
(when make-directory
(make-directory (file-name-directory file-name) 'parents))
file-name)
dir)))
(defun acdw/find-emacs-source () ;; doesn't work right now
"Find where Emacs' source tree is."
(acdw/system
(:work (expand-file-name
(concat "~/src/emacs-" emacs-version "/src")))
(:home (expand-file-name "~/src/pkg/emacs/src/emacs-git/src"))
(:other nil)))
(defun acdw/gc-disable ()
"Functionally disable the Garbage collector."
(setq gc-cons-threshold most-positive-fixnum
gc-cons-percentage 0.8))
(defun acdw/gc-enable ()
"Enable the Garbage collector."
(setq gc-cons-threshold (* 800 1024 1024)
gc-cons-percentage 0.1))
(defun acdw/insert-iso-date (arg)
"Insert the ISO-8601-formatted date, optionally including time (pass ARG)."
(interactive "P")
(let ((format (if arg "%FT%T%z" "%F")))
(insert (format-time-string format (current-time)))))
(defun acdw/kill-a-buffer (&optional prefix)
"Kill this buffer, or other buffers, depending on PREFIX.
\\[acdw/kill-a-buffer] : Kill CURRENT buffer and window
\\[universal-argument] \\[acdw/kill-a-buffer] : Kill OTHER buffer and window
\\[universal-argument] \\[universal-argument] \\[acdw/kill-a-buffer] : Kill ALL OTHER buffers and windows
Prompt only if there are unsaved changes."
(interactive "P")
(pcase (or (car prefix) 0)
(0 (kill-current-buffer)
(unless (one-window-p) (delete-window)))
(4 (other-window 1)
(kill-current-buffer)
(unless (one-window-p) (delete-window)))
(16 (mapc 'kill-buffer (delq (current-buffer) (buffer-list)))
(delete-other-windows))))
(defun acdw/sunrise-sunset (sunrise-command sunset-command)
"Run SUNRISE-COMMAND at sunrise, and SUNSET-COMMAND at sunset."
(let* ((times-regex (rx (* nonl)
(: (any ?s ?S) "unrise") " "
(group (repeat 1 2 digit) ":"
(repeat 1 2 digit)
(: (any ?a ?A ?p ?P) (any ?m ?M)))
(* nonl)
(: (any ?s ?S) "unset") " "
(group (repeat 1 2 digit) ":"
(repeat 1 2 digit)
(: (any ?a ?A ?p ?P) (any ?m ?M)))
(* nonl)))
(ss (acdw/supress-messages #'sunrise-sunset))
(_m (string-match times-regex ss))
(sunrise-time (match-string 1 ss))
(sunset-time (match-string 2 ss)))
(run-at-time sunrise-time (* 60 60 24) sunrise-command)
(run-at-time sunset-time (* 60 60 24) sunset-command)
(run-at-time "12:00am" (* 60 60 24) sunset-command)))
(defun acdw/supress-messages (oldfn &rest args) ; from pkal
"Advice wrapper for suppressing `message'.
OLDFN is the wrapped function, that is passed the arguments
ARGS."
(let ((msg (current-message)))
(prog1
(let ((inhibit-message t))
(apply oldfn args))
(when msg
(message "%s" msg)))))
(defun acdw/setup-fringes ()
"Set up fringes how I likes 'em."
(define-fringe-bitmap 'left-curly-arrow
[#b01100000
#b00110000
#b00011000
#b00001100]
4 8 'center)
(define-fringe-bitmap 'right-curly-arrow
[#b00000011
#b00000110
#b00001100
#b00011000]
4 8 'center)
(define-fringe-bitmap 'left-arrow
[#b01100000
#b01010000]
2 8 '(top t))
(define-fringe-bitmap 'right-arrow
[#b00000011
#b00000101]
2 8 '(top t))
(setq-local indicate-empty-lines nil
indicate-buffer-boundaries '((top . right)
(bottom . right)))
(custom-set-faces '(fringe
((t (:foreground "dim gray"))))))
(defun acdw/require-private ()
"Load \"~/.emacs.d/private.el\".
It's called 'require-private' for historical reasons."
(load (expand-file-name "private.el" user-emacs-directory)
:noerror :nomessage))
;;; Recentf renaming with dired
;; from ... somewhere. 'rjs', apparently?
;; I'm throwing these here because they look better here than in init.el.
;; Comments are "rjs"'s.
;; Magic advice to rename entries in recentf when moving files in
;; dired.
(defun rjs/recentf-rename-notify (oldname newname &rest _args)
"Magically rename files from OLDNAME to NEWNAME when moved in `dired'."
(if (file-directory-p newname)
(rjs/recentf-rename-directory oldname newname)
(rjs/recentf-rename-file oldname newname)))
(defun rjs/recentf-rename-file (oldname newname)
"Rename a file from OLDNAME to NEWNAME in `recentf-list'."
(setq recentf-list
(mapcar (lambda (name)
(if (string-equal name oldname)
newname
oldname))
recentf-list)))
(defun rjs/recentf-rename-directory (oldname newname)
"Rename directory from OLDNAME to NEWNAME in `recentf-list'."
;; oldname, newname and all entries of recentf-list should already
;; be absolute and normalised so I think this can just test whether
;; oldname is a prefix of the element.
(setq recentf-list
(mapcar (lambda (name)
(if (string-prefix-p oldname name)
(concat newname (substring name (length oldname)))
name))
recentf-list)))
;;; Sort setq...
;; https://emacs.stackexchange.com/questions/33039/
(defun sort-setq ()
"Sort a setq. Must be a defun."
(interactive)
(save-excursion
(save-restriction
(let ((sort-end (progn (end-of-defun)
(backward-char)
(point-marker)))
(sort-beg (progn (beginning-of-defun)
(re-search-forward "[ \\t]*(" (point-at-eol))
(forward-sexp)
(re-search-forward "\\_<" (point-at-eol))
(point-marker))))
(narrow-to-region (1- sort-beg) (1+ sort-end))
(sort-subr nil #'sort-setq-next-record #'sort-setq-end-record)))))
(defun sort-setq-next-record ()
"Sort the next record of a `setq' form."
(condition-case nil
(progn
(forward-sexp 1)
(backward-sexp))
('scan-error (goto-char (point-max)))))
(defun sort-setq-end-record ()
"Sort the end of a `setq' record."
(condition-case nil
(forward-sexp 2)
('scan-error (goto-char (point-max)))))
;;; Crux tweaks
;; `crux-other-window-or-switch-buffer' doesn't take an argument.
(defun acdw/other-window-or-switch-buffer (&optional arg)
"Call `other-window' with ARG or switch buffers, depending on window count."
(interactive "P")
(if (one-window-p)
(switch-to-buffer nil)
(other-window (or arg 1))))
(defun acdw/other-window-or-switch-buffer-backward ()
"Do `acdw/other-window-or-switch-buffer', but backward."
(interactive)
(acdw/other-window-or-switch-buffer -1))
;;; Auth-sources
;; https://github.com/emacs-circe/circe/wiki/Configuration
(defun acdw/fetch-password (&rest params)
"Fetch a password from `auth-source' using PARAMS.
This function is internal. Use `acdw/make-password-fetcher' instead."
(let ((match (car (apply #'auth-source-search params))))
(if match
(let ((secret (plist-get match :secret)))
(if (functionp secret)
(funcall secret)
secret))
(message "Password not found for %S" params))))
(defun acdw/make-password-fetcher (&rest params)
"Make a function that will call `acdw/fetch-password' with PARAMS."
(lambda (&rest _)
(apply #'acdw/fetch-password params)))
;;; Paren annoyances
(defun acdw/stop-paren-annoyances (&optional buffer)
"Locally turn off paren-checking functions in BUFFER."
(with-current-buffer (or buffer (current-buffer))
(setq-local blink-matching-paren nil
show-paren-mode nil)))
;;; 💩
(defun 💩 (&optional n)
"💩 x N."
(interactive "p")
(let ((n (or n 1)))
(while (> n 0)
(insert "💩")
(setq n (1- n)))))
(defun spongebob-case-region (beg end)
"Make region, defined by BEG and END, lOoK lIkE tHiS."
(interactive "*r")
(save-excursion
(let (case)
(goto-char beg)
(while (< (point) end)
(if (looking-at "[[:alpha:]]")
(if (setq case (not case))
(upcase-region (point) (progn (forward-char 1) (point)))
(downcase-region (point) (progn (forward-char 1) (point))))
(forward-char 1))))))
(defun spongebob-case-word (n)
"Spongebob-case N words forward, beginning at point, moving over."
(interactive "*p")
(spongebob-case-region (point) (progn (forward-word n) (point))))
(defun spongebob-case-dwim (arg)
"Spongebob-case words in the region if active, else word at point.
If ARG exists, it's passed to `spongebob-case-word'."
(interactive "*p")
(if (use-region-p)
(spongebob-case-region (region-beginning) (region-end))
(spongebob-case-word arg)))
;;; Fat finger solutions
(defun acdw/fat-finger-exit (&optional prefix)
"Delete a frame, or kill Emacs with confirmation.
When called with PREFIX, just kill Emacs without confirmation."
(interactive "P")
(if (or prefix
(and (= 1 (length (frame-list)))
(yes-or-no-p "This is the last frame! Wanna quit?")))
(kill-emacs)
(ignore-errors
(delete-frame))))
(defun acdw/disabled-command-function (&optional cmd keys)
(let ((cmd (or cmd this-command))
(keys (or keys (this-command-keys))))
;; this logic stolen from original `disabled-command-function'
(if (or (eq (aref keys 0) (if (stringp keys)
(aref "\M-x" 0)
?\M-x))
(and (>= (length keys) 2)
(eq (aref keys 0) meta-prefix-char)
(eq (aref keys 1) ?x)))
;; it's been run as an M-x command, we want to do it
(call-interactively cmd)
;; else, tell the user it's disabled.
(message (substitute-command-keys
(concat "Command `%s' has been disabled. "
"Run with \\[execute-extended-command]."))
cmd))))
;;; cribbed
;; https://jao.io/blog/2021-09-08-high-signal-to-noise-emacs-command.html
(defun jao-buffer-same-mode (&rest modes)
"Pop to a buffer with a mode among MODES, or the current one if not given."
(interactive)
(let* ((modes (or modes (list major-mode)))
(pred (lambda (b)
(let ((b (get-buffer (if (consp b) (car b) b))))
(member (buffer-local-value 'major-mode b) modes)))))
(pop-to-buffer (read-buffer "Buffer: " nil t pred))))
(provide 'acdw)
;;; acdw.el ends here