My Emacs configuration.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 

699 lines
26 KiB

;;; db-utils.el --- Utility Functions for Daniel's Emacs Configuration -*- lexical-binding: t -*-
;;; Commentary:
;;
;; Some functions used in my ~/.emacs.d/init.el. Most of them are copied from
;; various sources around the internet.
;;
;;; Code:
(require 'subr-x)
(require 'cl-lib)
(require 'dash)
(require 'db-customize)
(require 'bookmark)
(require 'term)
(require 'nsm)
(require 'compile)
(require 'calc)
(require 'calc-forms)
(require 'ert)
(require 's)
(autoload 'async-start "async")
(autoload 'lispy-mode "lispy")
(autoload 'ldap-search "ldap")
(declare-function w32-shell-execute "w32fns.c")
;;; Application Shortcuts
(defun db/run-or-hide-ansi-term ()
"Find `*ansi-term*' or run `ansi-term' with `explicit-shell-file-name'.
If already in `*ansi-term*' buffer, bury it."
(interactive)
(if (string= "term-mode" major-mode)
(bury-buffer)
(if (get-buffer "*ansi-term*")
(switch-to-buffer "*ansi-term*")
(ansi-term explicit-shell-file-name))))
(defun db/gnus ()
"Switch to the `*Group*' buffer, starting `gnus' if not existent."
(interactive)
(require 'gnus)
(if (get-buffer "*Group*")
(switch-to-buffer "*Group*")
(gnus)))
(defun db/org-agenda ()
"Show the main `org-agenda'."
(interactive)
(org-agenda nil "A"))
(defun db/scratch ()
"Switch to `*scratch*'."
(interactive)
(switch-to-buffer "*scratch*"))
(defun db/find-user-init-file ()
"Edit `user-init-file'."
(interactive)
(find-file user-init-file))
(defun db/run-or-hide-shell (arg)
"Opens a shell buffer in new window if not already in one.
Otherwise, closes the current shell window. With ARG, switch
to `default-directory' of the current buffer first."
;; idea to split the current window is from
;; http://howardism.org/Technical/Emacs/eshell-fun.html
(interactive "P")
(cl-flet ((change-to-shell ()
(if-let ((shell-window (db/find-window-by-buffer-mode 'shell-mode)))
(select-window shell-window)
;; open shell in buffer with height of ⅓ of current window
(let ((height (/ (window-total-height) 3)))
(shell)
(enlarge-window (- height (window-total-height)))))))
(if (not arg)
;; toggle shell window
(if (not (derived-mode-p 'shell-mode))
(change-to-shell)
(bury-buffer)
(delete-window))
;; unconditionally go to shell, and also change to cwd
(let ((current-dir (expand-file-name default-directory)))
(change-to-shell)
(end-of-line)
(comint-kill-input)
(insert (format "cd '%s'" current-dir))
(comint-send-input)))))
;;; General Utilities
(defun db/get-url-from-link ()
"Copy url of link under point into clipboard."
(interactive)
(let ((url (plist-get (text-properties-at (point)) 'help-echo)))
(if url
(kill-new url)
(error "No link found"))))
(defun db/test-emacs ()
;; from oremacs
"Test whether emacs' configuration is not throwing any errors."
(interactive)
(require 'async)
(async-start
(lambda () (shell-command-to-string
"emacs --batch --eval \"
(condition-case e
(progn
(load \\\"~/.emacs.d/init.el\\\")
(message \\\"-OK-\\\"))
(error
(message \\\"ERROR!\\\")
(signal (car e) (cdr e))))\""))
`(lambda (output)
(if (string-match "-OK-" output)
(when ,(called-interactively-p 'any)
(message "All is well"))
(switch-to-buffer-other-window "*startup error*")
(delete-region (point-min) (point-max))
(insert output)
(search-backward "ERROR!")))))
(defun db/isearch-forward-symbol-with-prefix (p)
;; http://endlessparentheses.com/quickly-search-for-occurrences-of-the-symbol-at-point.html
"Like `isearch-forward', unless prefix argument is provided.
With a prefix argument P, isearch for the symbol at point."
(interactive "P")
(let ((current-prefix-arg nil))
(call-interactively
(if p
#'isearch-forward-symbol-at-point
#'isearch-forward))))
(defun endless/fill-or-unfill ()
"Like `fill-paragraph', but unfill if used twice."
;; http://endlessparentheses.com/fill-and-unfill-paragraphs-with-a-single-key.html
(interactive)
(let ((fill-column
(if (eq last-command 'endless/fill-or-unfill)
(progn (setq this-command nil)
(point-max))
fill-column)))
(call-interactively #'fill-paragraph)))
(defun db/delete-trailing-whitespace-maybe ()
"Call `delete-trailing-whitespace', but not in `message-mode'."
(unless (derived-mode-p 'message-mode)
(delete-trailing-whitespace)))
(defun db/find-window-by-buffer-mode (mode)
"Return first window in current frame displaying a buffer with
major mode MODE."
(cl-find-if (lambda (window)
(with-current-buffer (window-buffer window)
(eq major-mode mode)))
(window-list-1)))
(defun db/hex-to-ascii (hex-string)
"Convert HEX-STRING to its ASCII equivalent.
Allowed characters in hex-string are hexadecimal digits and
whitespaces. If region is active, replace region by the
corresponding ASCII string, otherwise query for input and display
the result in the minibuffer."
;; https://stackoverflow.com/questions/12003231/how-do-i-convert-a-string-of-hex-into-ascii-using-elisp
(interactive (list (if (use-region-p)
(buffer-substring-no-properties (region-beginning) (region-end))
(read-from-minibuffer "String (hex): "))))
(cl-assert (not (string-match-p "[^A-Fa-e0-9 \t\n]" hex-string))
"String contains invalid characters.")
(let ((result (->> hex-string
(replace-regexp-in-string "[ \t\n]" "")
(string-to-list)
(-partition 2)
(--map (string-to-number (concat it) 16))
concat)))
(if (use-region-p)
(progn
(delete-region (region-beginning) (region-end))
(dolist (char (string-to-list result))
(insert-byte char 1)))
(message result))))
(defun db/text-to-hex (text-string)
"Convert TEXT-STRING to its hexadecimal representation.
This function will return hexadecimal numbers with more than two
digits if the input string contains wide characters. The result
might depend on the coding system of the current buffer."
(interactive (list (if (use-region-p)
(buffer-substring-no-properties (region-beginning) (region-end))
(read-from-minibuffer "String (ascii): "))))
(let ((result (->> text-string
(--map (format "%02X " it))
(apply #'concat)
(string-trim-right))))
(if (use-region-p)
(progn
(delete-region (region-beginning) (region-end))
(insert result))
(message result))))
(defun db/ntp-to-time (high low &optional format-string)
"Format NTP time given by HIGH and LOW to time as given by FORMAT-STRING.
HIGH and LOW must both be 8 digit hex strings. If not given,
FORMAT-STRING defaults to some ISO 8601-like format."
(interactive (cl-flet ((read-hex (prompt)
(let ((input-proper (->> prompt
(read-string)
(replace-regexp-in-string "[\n\t ]" ""))))
(if (not (string-match-p "[0-9a-fA-F]\\{8\\}" input-proper))
(user-error "Input invalid, must be an 8 digit hex string.")
(string-to-number input-proper 16)))))
(list (read-hex "High (hex): ")
(read-hex "Low (hex): "))))
(let* ((calc-internal-prec 30)
(unix-time (calcFunc-unixtime (calc-eval (format "%s - 2208988800 + (%s/4294967296)" high low)
'raw)
;; we explicitly call `calcFunc-unixtime'
;; here to set the time zone to UTC
0))
(time-string (format (or format-string
"%04d-%02d-%02dT%02d:%02d:%012.9fZ")
(calcFunc-year unix-time)
(calcFunc-month unix-time)
(calcFunc-day unix-time)
(calcFunc-hour unix-time)
(calcFunc-minute unix-time)
;; `seconds' will be a floating point number, and we need to format
;; it with a precision that is high enough; apparently, we also need
;; to truncate the number of seconds to nine digits, at least that
;; is what has been done in the test example we use in the
;; corresponding regression test …
(string-to-number
(calc-eval "trunc(second($), 9)" 'num unix-time)))))
(if (called-interactively-p 'interactive)
(message time-string)
time-string)))
(defun conditionally-enable-lispy ()
"Enable lispy-mode when in `eval-expression’ or in
`pp-eval-expression’. lispy must have been loaded for this
first, i.e., this function will not automatically load
lispy."
(when (and (featurep 'lispy)
(or (eq this-command 'eval-expression)
(eq this-command 'pp-eval-expression)))
(lispy-mode 1)))
(defun turn-on-lispy-when-available ()
"Activate `lispy’ in current buffer when possible.
Will print a warning in case of failure."
(interactive)
(with-demoted-errors "Cannot activate lispy: %s"
(require 'lispy)
(lispy-mode)))
(defun turn-on-flycheck-when-file ()
"Turn on `flycheck-mode' when buffer is associated with a file."
(when buffer-file-name
(flycheck-mode +1)))
(defun db/sort-nsm-permanent-settings ()
"Sort values in `nsm-permanent-host-settings’."
(setq nsm-permanent-host-settings
(cl-sort nsm-permanent-host-settings
#'string<
:key #'cl-second)))
(defun endless/colorize-compilation ()
"Colorize from `compilation-filter-start' to `point'."
;; http://endlessparentheses.com/ansi-colors-in-the-compilation-buffer-output.html
(let ((inhibit-read-only t))
(ansi-color-apply-on-region compilation-filter-start (point))))
(defun db/turn-off-local-electric-pair-mode ()
"Locally turn off electric pair mode."
(interactive)
(electric-pair-local-mode -1))
(defun db/pretty-print-xml ()
"Stupid function to pretty print XML content in current buffer."
;; We assume that < and > only occur as XML tag delimiters, not in strings;
;; this function is not Unicode-safe
(interactive)
(unless (eq major-mode 'nxml-mode)
(require 'nxml-mode)
(nxml-mode))
(save-mark-and-excursion
;; First make it all into one line
(goto-char (point-min))
(while (re-search-forward "\n[\t ]*" nil 'no-error)
;; In case there was a space, we have to keep at least one as a separator
(if (save-match-data (looking-back "[\t ]" 1))
(replace-match " ")
(replace-match "")))
;; Next break between tags
(goto-char (point-min))
(while (re-search-forward ">[\t ]*<" nil 'no-error)
(replace-match ">\n<"))
;; Move opening and closing tags to same line in case there’s nothing in
;; between
(goto-char (point-min))
(while (re-search-forward "<\\([^>]*\\)>\n</\\1>" nil 'no-error)
(replace-match "<\\1></\\1>"))
;; Indent
(indent-region (point-min) (point-max))))
(defun db/lookup-smime-key (mail)
"Look up `MAIL' on ldap-server of the DFN.
If found, imports the certificate via gpgsm."
;; inspired by https://www.emacswiki.org/emacs/ExtendSMIME
(interactive "sMail: ")
(require 'ldap)
(when (get-buffer " *ldap-value*")
(kill-buffer " *ldap-value*"))
(ldap-search (format "(mail=%s)" mail))
(let ((bufval (get-buffer " *ldap-value*")))
(when bufval
(with-current-buffer bufval
(save-restriction
(widen) ; just to be sure
(let ((result (call-process-region (point-min) (point-max)
"gpgsm"
nil nil nil
"--import")))
(if (zerop result)
(message "Successfully imported certificate for <%s>" mail)
(error "Could not import certificate for <%s>" mail))))))))
;; https://emacs.stackexchange.com/questions/3089/how-can-i-create-a-dired-buffer-listing-all-open-files
;; https://emacs.stackexchange.com/questions/2567/programmatically-insert-files-into-dired-buffer
(defun db/dired-from-shell-command (command &optional directory)
"Run COMMAND in DIRECTORY and display resulting list of files via `dired’.
COMMAND must be a shell command that produces a list of files as
output, separated by \\n, when called with
`shell-command-to-string’. DIRECTORY defaults to
`default-directory’."
(interactive "sCommand: ")
(when (and directory (not (directory-name-p directory)))
(user-error "Value for DIRECTORY is not a directory name: %s"
directory))
(let* ((default-directory (or directory default-directory))
(list-of-files (cl-remove-if-not
(lambda (entry)
(and (not (string-empty-p entry))
(or (file-exists-p entry)
(file-symlink-p entry))))
(split-string (shell-command-to-string command)
"\n"))))
(if (null list-of-files)
(message "No files return by command “%s”" command)
(dired (cons "Command output" list-of-files)))))
(defun db/dired-from-git-annex (matching-options)
"Display files found by git annex with MATCHING-OPTIONS.
This runs “git annex find” with MATCHING-OPTIONS (a string) in
`default-directory' and displays the resulting set of files using
`dired'."
(interactive (list (read-string (format "Matching Options (in %s): "
default-directory))))
(db/dired-from-shell-command (format "git annex find . %s" matching-options)
default-directory))
(defun db/system-open (path)
"Open PATH with default program as defined by the underlying system."
(cond
((eq system-type 'windows-nt)
(w32-shell-execute "open" path))
((eq system-type 'cygwin)
(start-process "" nil "cygstart" path))
(t
(start-process "" nil "xdg-open" path))))
(defun keyboard-quit-context+ ()
"Quit current context.
This function is a combination of `keyboard-quit' and
`keyboard-escape-quit' with some parts omitted and some custom
behavior added. When the minibuffer is active, quit it
regardless of the currently selected window."
;; https://with-emacs.com/posts/tips/quit-current-context/
(interactive)
(cond ((region-active-p)
;; Avoid adding the region to the window selection.
(setq saved-region-selection nil)
(let (select-active-regions)
(deactivate-mark)))
((eq last-command 'mode-exited) nil)
(current-prefix-arg
nil)
(defining-kbd-macro
(message
(substitute-command-keys
"Quit is ignored during macro defintion, use \\[kmacro-end-macro] if you want to stop macro definition"))
(cancel-kbd-macro-events))
((active-minibuffer-window)
(when (get-buffer-window "*Completions*")
;; hide completions first so point stays in active window when
;; outside the minibuffer
(minibuffer-hide-completions))
(abort-recursive-edit))
(t
(when completion-in-region-mode
(completion-in-region-mode -1))
(let ((debug-on-quit nil))
(signal 'quit nil)))))
(defun db/convert-lf-to-crlf-in-buffer (&rest _stuff)
"Convert all LF to CRLF in current buffer.
Does not replace CRLF with CRCRLF, and so on."
(save-mark-and-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (re-search-forward "\n" nil 'noerror)
(unless (looking-back "\r\n" 2)
(replace-match "\r\n"))))))
(defun db/convert-crlf-to-lf-in-buffer (&rest _stuff)
"Convert all CRLF to LF in current buffer."
(save-mark-and-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (re-search-forward "\r\n" nil 'noerror)
(replace-match "\n")))))
(defun db/sync-magit-repos-from-projectile ()
"Update repositories known to magit from projectile's."
(interactive)
(require 'projectile)
(require 'magit)
(setq magit-repository-directories
(mapcar
(lambda (dir)
(cons (substring dir 0 -1) 0))
(cl-remove-if-not
(lambda (project)
(unless (file-remote-p project)
(file-exists-p (concat project "/.git"))))
projectile-known-projects))))
;; Base45 Decoding
;; This is based on https://datatracker.ietf.org/doc/draft-faltstrom-base45/,
;; which in turned may be used in data encoded for QR codes.
(let ((translation-hash-table (make-hash-table)))
(puthash ?0 00 translation-hash-table)
(puthash ?1 01 translation-hash-table)
(puthash ?2 02 translation-hash-table)
(puthash ?3 03 translation-hash-table)
(puthash ?4 04 translation-hash-table)
(puthash ?5 05 translation-hash-table)
(puthash ?6 06 translation-hash-table)
(puthash ?7 07 translation-hash-table)
(puthash ?8 08 translation-hash-table)
(puthash ?9 09 translation-hash-table)
(puthash ?A 10 translation-hash-table)
(puthash ?B 11 translation-hash-table)
(puthash ?C 12 translation-hash-table)
(puthash ?D 13 translation-hash-table)
(puthash ?E 14 translation-hash-table)
(puthash ?F 15 translation-hash-table)
(puthash ?G 16 translation-hash-table)
(puthash ?H 17 translation-hash-table)
(puthash ?I 18 translation-hash-table)
(puthash ?J 19 translation-hash-table)
(puthash ?K 20 translation-hash-table)
(puthash ?L 21 translation-hash-table)
(puthash ?M 22 translation-hash-table)
(puthash ?N 23 translation-hash-table)
(puthash ?O 24 translation-hash-table)
(puthash ?P 25 translation-hash-table)
(puthash ?Q 26 translation-hash-table)
(puthash ?R 27 translation-hash-table)
(puthash ?S 28 translation-hash-table)
(puthash ?T 29 translation-hash-table)
(puthash ?U 30 translation-hash-table)
(puthash ?V 31 translation-hash-table)
(puthash ?W 32 translation-hash-table)
(puthash ?X 33 translation-hash-table)
(puthash ?Y 34 translation-hash-table)
(puthash ?Z 35 translation-hash-table)
(puthash ?\s 36 translation-hash-table)
(puthash ?$ 37 translation-hash-table)
(puthash ?% 38 translation-hash-table)
(puthash ?* 39 translation-hash-table)
(puthash ?+ 40 translation-hash-table)
(puthash ?- 41 translation-hash-table)
(puthash ?. 42 translation-hash-table)
(puthash ?/ 43 translation-hash-table)
(puthash ?: 44 translation-hash-table)
(defun db/base45--string-to-bytes (str)
"Translate base45 input string to list of numbers as per specification."
(-map (lambda (char)
(or (gethash char translation-hash-table)
(user-error "Invalid character in string for base45 decoding: %c" char)))
str)))
(defun db/base45-decode-string (str)
"Decode base45 string STR and return the result as a string."
(when (= 1 (% (length str) 3))
(user-error "Input string has invalid length for base45 decoding; must be 0 or 2 modulo 3"))
(let* ((str (s-upcase str))
(list-of-blocks (->> str
db/base45--string-to-bytes
(-partition-all 3)))
(list-of-numbers (-map (lambda (block)
(+ (* 45 45 (or (nth 2 block) 0))
(* 45 (nth 1 block))
(nth 0 block)))
list-of-blocks))
(list-of-bytes (nconc (-mapcat (lambda (num)
(list (/ num 256)
(% num 256)))
(-butlast list-of-numbers))
(let ((last-one (-last-item list-of-numbers)))
(if (< last-one 256)
;; When the last element represents only
;; one byte, discard the extra 0 that (/
;; last-one 256) would produce …
(list last-one)
;; … else handle the last element like all
;; the others
(list (/ last-one 256)
(% last-one 256)))))))
(apply #'string list-of-bytes)))
(ert-deftest db/base45-decode-string--basic-tests ()
"Test basic decoding examples"
;; dash is funny :)
(-each '(("QED8WEX0" "ietf!")
("X.CT3EGEC" "foobar")
("x.ct3egec" "foobar"))
(-lambda ((in out))
(should (equal out (db/base45-decode-string in))))))
(defun db/base45-decode-region (beg end)
"Base45-decode region between BEG and END.
Replaces the region by the result of the decoding."
(interactive "r")
(let ((replace-string (db/base45-decode-string (buffer-substring-no-properties beg end))))
(kill-region beg end)
;; Using `insert' and `insert-char' directly uses character conversion and
;; may scramble bytes with the eight bit set; let's try `insert-byte'
;; instead.
(dolist (char (string-to-list replace-string))
(insert-byte char 1))))
(ert-deftest db/base45-decode-region--insert-correct-bytes ()
"Test whether bytes are always inserted.
Take the start of a compressed EU Digital Covid Certificate and
insert into a temporary buffer; check that indeed the expected
number of bytes has been inserted."
(let ((encoded-string "6BFOXN"))
(with-temp-buffer
(insert encoded-string)
(db/base45-decode-region (point-min) (point-max))
(message "%s" (string-to-list (buffer-string)))
;; (120 4194204 4194235 4194260) is Emacs' internal representation of
;; x\234\273\324, where the last three bytes are raw-byte; when
;; non-raw-bytes would have been inserted, it would be (120 156 …)
(should (equal '(120 4194204 4194235 4194260)
(string-to-list (buffer-string)))))))
;;; Extend Input Methods
(defun db/add-symbols-to-TeX-input-method ()
"Add some new symbols to TeX input method."
(when (string= current-input-method "TeX")
(let ((quail-current-package (assoc "TeX" quail-package-alist)))
(quail-define-rules
((append . t))
("\\land" ?∧)
("\\lor" ?∨)
("\\lnot" )
("\\implies" ?⇒)
("\\powerset" ?𝔓)
("\\mathbbK" ?𝕂)
("\\mathbbR" ?ℝ)
("\\mathbbN" ?ℕ)
("\\mathbbZ" ?ℤ)
("\\mathbbP" ?ℙ)
("\\mathcalA" ?𝒜)
("\\mathcalB" ?ℬ)
("\\mathcalC" ?𝒞)
("\\mathcalD" ?𝒟)
("\\mathcalE" ?ℰ)
("\\mathcalH" ?ℋ)
("\\mathcalI" ?ℐ)
("\\mathcalJ" ?𝒥)
("\\mathcalK" ?𝒦)
("\\mathcalL" ?ℒ)
("\\mathcalM" ?ℳ)
("\\mathcalR" ?ℛ)
("\\mathcalQ" ?𝒬)
("\\mathcalS" ?𝒮)
("\\mathfrakP" ?𝔓)))))
;;; Wrappers for external applications
(defun db/two-monitors-xrandr ()
"Activate second monitor using xrandr."
(call-process "xrandr" nil nil nil
"--output" "HDMI-3" "--primary" "--right-of" "LVDS-1" "--auto"))
(defun db/one-monitor-xrandr ()
"Deactivate all additional monitors."
(call-process "xrandr" nil nil nil
"--output" "HDMI-3" "--off"))
;;; Bookmarks
(defun db/bookmark-add-with-handler (name location handler)
"Add NAME as bookmark to LOCATION and use HANDLER to open it.
HANDLER is a function receiving a single argument, namely
LOCATION. If a bookmark named NAME is already present, replace
it. The bookmarks will finally be sorted by their name."
(setq bookmark-alist
(cl-delete-if #'(lambda (bmk) (equal (car bmk) name))
bookmark-alist))
(push `(,name
(filename . ,location)
(handler . ,#'(lambda (arg)
(funcall handler (cdr (assoc 'filename arg))))))
bookmark-alist)
(setq bookmark-alist (cl-sort bookmark-alist #'string-lessp :key #'car)))
(defun db/bookmark-add-external (location name)
"Add NAME as bookmark to LOCATION that is opened by the operating system.
Offers simple completing from the list of recently opened files.
In dired, offer all marked files or the currently selected file
as completing instead."
(interactive (list (completing-read "Location: " (if (derived-mode-p 'dired-mode)
(dired-get-marked-files)
recentf-list))
(read-string "Name: ")))
(db/bookmark-add-with-handler name location #'db/system-open))
(defun db/bookmark-add-url (url name)
"Add NAME as bookmark to URL that is opened by `browse-url’."
(interactive "sURL: \nsName: ")
(db/bookmark-add-with-handler name url #'browse-url))
(defun db/bookmark-add-eww (url name)
"Add NAME as bookmark to URL to be opened with `eww’."
(interactive "sURL: \nsName: ")
(db/bookmark-add-with-handler name url #'eww))
;;; Appearance
(defun db/switch-to-dark-theme ()
"Switch to dark theme.
This is `db-dark' and `solarized-dark'."
(interactive)
(load-theme 'solarized-dark)
(load-theme 'db-dark))
(defun db/switch-to-light-theme ()
"Switch to dark theme.
This is `db-light' and `solarized-light'."
(interactive)
(load-theme 'solarized-light)
(load-theme 'db-light))
;;; End
(provide 'db-utils)
;;; db-utils.el ends here