The GNU Emacs package rcd-utilities.el contains basic Emacs Lisp utilities used by other packages that we are publishing here @ GNU.Support
Simply save the below code from a hyperlink, then install it with:
{M-x package-install-file RET rcd-utilities.el RET}or download the file from: https://gnu.support/files/emacs/packages/rcd-utilities.el
and install it with:
{M-x package-install-file RET rcd-utilities.el RET}This file rcd-utilities.el is updated throughout the time with
new functions.
;;; rcd-utilities.el --- RCD utilities for GNU Emacs Lisp -*- lexical-binding: t; -*-
;; Copyright (C) 2016-2020 Jean Louis
;; Author: Jean Louis <bugs@gnu.support>
;; Version: 1.81
;; Package-Requires: (calendar)
;; Keywords: extensions
;; URL: https://gnu.support/gnu-emacs/packages/rcd-utilities-el.html
;; This file is not part of GNU Emacs.
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; These are the RCD utilities for GNU Emacs Lisp used in other RCD
;; packages.
;;
;;
;;
;; RCD is acronym for Reach, Connect, Deliver, my personal
;; principle and formula for Wealth.
;;; Change Log:
;;; Code:
;;;; ↝ INITIALIZATION
(setq lexical-binding t)
(require 'browse-url)
(require 'calendar)
(require 'cl-lib)
(require 'dired)
(require 'hi-lock)
(require 'rcd-template nil t)
(require 'seq)
(require 'subr-x)
; (require 'rcd-template)
;;;; ↝ CUSTOMIZATION
(defcustom rcd-current-project-directory "~/Programming/emacs-lisp/"
"Defines current project directory. This relates to Emacs Lisp
projects and is used as default by some of RCD utilities."
:group 'rcd
:type 'string)
(defcustom rcd-public-html-basedir "public_html"
"Defines the base name of users's public_html directory"
:group 'rcd
:type 'string)
(defcustom rcd-public-html-dir (concat (getenv "HOME") "/" rcd-public-html-basedir)
"Defines full path for user's public_html directory"
:group 'rcd
:type 'string)
(defcustom rcd-warning-message-sound-file nil
"The sound file for warning messages"
:group 'rcd
:type 'string)
(defcustom rcd-external-editor "notepadqq"
"The external editor as an option for some functions"
:group 'rcd
:type 'string)
(defcustom rcd-external-pdf-viewer "evince"
"The external PDF viewer for some previewing functions."
:group 'rcd
:type 'string)
;;;; ↝ VARIABLES
(defvar *image-default-resize-size* 1536)
(defvar *image-resize-sizes* '())
(defvar-local rcd-tabulated-refresh-function nil
"The function to refresh the tabulated list")
(put 'rcd-tabulated-refresh-function 'permanent-local t)
(defvar-local rcd-current-table nil
"Buffer local variable to designate the edited database table.")
(defvar-local rcd-current-column nil
"Buffer local variable to designate the edited database column.")
(defvar-local rcd-current-table-id nil
"Buffer local variable to designate the edited table ID.")
(defvar-local rcd-current-hash nil
"Buffer local variable to designate the symbol of edited hash.")
(defvar-local rcd-markup-language nil
"Buffer local variable to signal the markup language.")
;;;; ↝ NOTIFICATION FUNCTIONS
(defun rcd-notify (summary body &optional expire-time icon urgency category hint)
"Use system command `notify-send' for system notifications.
SUMMARY and BODY must be provided.
Optional argument EXPIRE-TIME must be in miliseconds."
(let* ((part `(call-process "dbus-launch" nil nil nil "notify-send" ,summary ,body))
(part (if expire-time (append part (list "-t" expire-time)) part))
(part (if icon (append part (list "-i" icon)) part))
(part (if urgency (append part (list "-u" urgency)) part))
(part (if category (append part (list "-c" category)) part))
(part (if hint (append part (list "-h" hint)) part)))
(eval part)))
;;;; ↝ STRING FUNCTIONS
(defun string-cut-id (s)
"Returns the ID number, integer, from beginning of a string,
whereby space must follow the ID number, without many checks."
(let* ((until (string-match " " s)))
(if until
(string-to-number (substring s nil until))
nil)))
(defun string-cut-id-with-part (s)
"Returns the ID as number and first part of string in a string
that contains space after the ID, otherwise nil"
(let* ((space (string-match " " s)))
(if space
(let* ((id (substring s 0 space))
(id (string-to-number id))
(rest (substring s (1+ space))))
(if id (list id rest) nil))
nil)))
(defun string-cut-right-square-bracket-reference (s)
"Returns the reference within square brackets on the end of S."
(let* ((space (string-match " " (reverse s))))
(if space
(let* ((id (substring (reverse s) 0 space)))
(if (and (string-match "\\[" id)
(string-match "\\]" id))
(replace-regexp-in-string "\\[\\\|\\]" "" (reverse id))
nil))
nil)))
(defun string-is-number-p (s)
(let ((s (string-trim s)))
(cond ((seq-empty-p s) nil)
((string-match "[^0123456789\\.]" s) nil)
((numberp (string-to-number s)) (string-to-number s)))))
(defun rcd-get-bracketed-id-end (s)
"Returns the ID number in string S from within first brackets on its
end. For example it would return 123 from `Some string [123]'"
(let* ((match (string-match "\\[\\([[:digit:]]*\\)\\][[:space:]]*$" s)))
(when match
(string-to-number
(substring-no-properties s (match-beginning 1) (match-end 1))))))
(defun slash-add-clean (string)
"Returns / on the end of the string if there is none"
(let* ((string (replace-regexp-in-string " *" "" string))
(slash (string-match "/$" string)))
(if slash string (concat string "/"))))
(defun slash-add (path)
"Adds slash `/` quickly on the end of string"
(if (string= path "")
"/"
(let ((last (substring (reverse path) 0 1)))
(if (string= last "/") path
(concat path "/")))))
(defun slash-remove (string)
"Removes / on the end of the string if there is some"
(replace-regexp-in-string "/*$" "" string))
(defun string-add (string add)
"Returns string 'add' on the end of the string if there is none"
(let* ((string (replace-regexp-in-string " *" "" string))
(added (string-match (format "%s$" add) string)))
(if added string (concat string add))))
(defun downcase-even-nil (s)
"Helps that downcase works even with nil strings, useful for comparison of SQL data"
(if (null s) ""
(downcase s)))
(defun single-quote (s)
(format "'%s'" s))
(defun shell-double-quote (s)
"Double quotes for the string that shall be fed to shell command"
(replace-regexp-in-string "\"" "\\\\\"" s))
(defun string-to-double-quotes (s)
(format "\"%s\"" s))
(defun string-to-single-quotes (s)
(format "'%s'" s))
(defun escape-$ (s)
"Escapes $ in strings, usually to avoid shell expansion"
(replace-regexp-in-string "\\$" "\$" s))
(defun rcd-string-not-empty-p (s)
"Returns T if string is empty or NIL"
(let ((s (if (null s) "" s)))
(if (stringp s)
(if (zerop (length s)) nil t))))
(defun string-blank-if-nil (s)
"Returns blank string for nil values"
(if (null s) "" s))
(defun string-or-empty-string (i)
"Returns empty string for nil"
(let* ((type (type-of i)))
(cond ((or (eql type 'integer)
(eql type 'float))
(number-to-string i))
((null i) "")
((eql type 'symbol) (prin1-to-string i))
((eql type 'string) i))))
(defun rcd-number-expand-dir (n)
"Expands any integer number to directory structure."
(let* ((s (number-to-string n))
(split (split-string s ""))
(join (string-join split "/")))
join))
(defun number-to-string-any (n)
"Returns string from N even if N is nil."
(cond ((null n) "")
((stringp n) n)
(t (number-to-string n))))
(defun insert-or-message (s)
"It will insert string in writable buffer or otherwise show it as
message."
(if buffer-read-only
(message s)
(insert s)))
(defun string-slug (s &optional random)
"Returns slug for Website Revision System by using string S.
RANDOM number may be added on the end."
(let* ((random (or random nil))
(case-fold-search t)
(s (replace-regexp-in-string "[^[:word:]]" " " s))
(s (replace-regexp-in-string " +" " " s))
(s (replace-regexp-in-string "ž" "z" s))
(s (replace-regexp-in-string "Ž" "Z" s))
(s (replace-regexp-in-string "š" "s" s))
(s (replace-regexp-in-string "Š" "S" s))
(s (replace-regexp-in-string "č" "c" s))
(s (replace-regexp-in-string "Č" "C" s))
(s (replace-regexp-in-string "Ć" "C" s))
(s (replace-regexp-in-string "ć" "c" s))
(s (replace-regexp-in-string "đ" "d" s))
(s (replace-regexp-in-string "Đ" "D" s))
(s (replace-regexp-in-string "^[[:space:]]+" "" s))
(s (replace-regexp-in-string "[[:space:]]+$" "" s))
(s (replace-regexp-in-string " " "-" s))
(s (if random (concat s "-" (number-to-string (random-number))) s)))
s))
(defun rcd-gpg-list-recipients ()
"Return list of GPG recipients either in Dired or for region.
If region is marked it will act on region, otherwise it may
handle current Dired file."
(interactive)
(if (eq major-mode 'dired-mode)
(let ((file (car (dired-get-marked-files))))
(message
(rcd-gpg-list-only
(with-temp-buffer
(insert-file-contents-literally file)
(buffer-string)))))
(if (region-active-p)
(message (rcd-gpg-list-only (rcd-region-string)))
(rcd-warning-message "Did not find valid encrypted region or file"))))
(defun rcd-gpg-list-only (encrypted)
"Return list of recipients for ENCRYPTED string."
(if (rcd-which "gpg")
(rcd-command-output-from-input "gpg" encrypted "--list-only" "--no-default-keyring" "--secret-keyring" "/dev/null")
(rcd-warning-message "RCD ERROR: `gpg' not found in $PATH")))
(defun region-to-variable-history nil "History fo `region-to-variable'.")
(defun region-to-variable (beg end)
"Set global variable by using marked region."
(interactive "r")
(when (use-region-p)
(let* ((region (buffer-substring-no-properties beg end))
(variable (read-from-minibuffer "(setq VARIABLE: " nil nil nil 'region-to-variable-history))
(variable (string-trim variable))
(format (format "(defvar %s %s)" variable (prin1-to-string region))))
(eval (read format)))))
(defun rcd-unenrich (enriched)
"Return un-enriched text from enriched string ENRICHED."
(with-temp-buffer
(enriched-mode 1)
(if (seq-empty-p enriched)
(insert "")
(insert (car (read-from-string enriched))))
(set-text-properties (point-min) (point-max) nil)
(buffer-string)))
(defun rcd-markdown-delete-anchors ()
(interactive)
(save-excursion
(goto-char 1)
(while (re-search-forward " <a name=\".*\"></a>" nil t)
(replace-match ""))))
(defun rcd-markdown-toc ()
(interactive)
(let* ((body (buffer-substring-no-properties (point-min) (point-max)))
(body (string-lines body))
(toc '()))
(erase-buffer)
(while body
(let* ((line (pop body))
(header (string-match (rx (+? "#") " ") line)))
(if header
(let* ((location (string-match " " line))
(from (1+ location))
(indent (* 2 (1- location)))
(heading (substring line from))
(id (string-slug heading))
(line (format "%s <a name=\"%s\"></a>" line id))
(link (concat (make-string indent #x20) (format "- [%s](#%s)" heading id))))
(push link toc)
(insert (format "%s\n" line)))
(insert (format "%s\n" line)))))
(kill-new (string-join (reverse toc) "\n"))))
;;;; ↝ CURRENCY FUNCTIONS
(defun eur-format (amount)
(format "€ %d" amount))
(defun usd-format (amount)
(format "US $%.2f" amount))
(defun usd (number)
(format "US $%s" number))
;;;; ↝ WRITING HELPERS
(defun rcd-kill-to-signature (arg)
"Kill all text up to the signature that begins with -- ."
(interactive "P")
(save-excursion
(save-restriction
(let ((point (point)))
(narrow-to-region point (point-max))
(push-mark)
(goto-char (point-min))
(if (re-search-forward "^-- $" nil t)
(forward-line 1)
(goto-char (point-max)))
(unless (eobp)
(if (and arg (numberp arg))
(forward-line (- -1 arg))
(end-of-line -1)))
(unless (= point (point))
(kill-region point (point))
(unless (bolp)
(insert "\n")))))))
;;;; ↝ HTML/XML FUNCTIONS
(defun xml-escape (string)
"Escape XML without matching problems"
(let ((chars (string-to-list string))
(nlist '()))
(while chars
(let ((char (char-to-string (pop chars))))
(push
(cond ((string= ">" char) ">")
((string= "<" char) "<")
((string= "\"" char) """)
((string= "'" char) "'")
((string= "&" char) "&")
((string= "™" char) "™")
(t char))
nlist)))
(list-of-strings-to-string (reverse nlist))))
(defun spaces-to-%20 (s)
(replace-regexp-in-string " " "%20" s))
(defun public-html-rest (path)
"Returns the string after public_html/ if there is anything or path"
(let* ((query (concat "/" (slash-add-clean rcd-public-html-basedir)))
(length-q (length query))
(length-p (length path))
(found (string-match query path)))
(if (and found (> length-p (+ found length-q)))
(let ((from (+ length-q found)))
(concat "https://" (spaces-to-%20 (substring path from))))
path)))
;;;; ↝ TEMPLATE INTERPOLATION FUNCTIONS
;; (let ((rx (rx "<%" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "-escape" (one-or-more (or blank "\n")) "%>")))
(defun rcd/expand-<%template%>-plist (template plist)
"Expands the template that contains <% @var var %> with plist member values from plist"
(let ((rx (rx "<%=" (one-or-more (or blank "\n")) "@var" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "-escape" (one-or-more (or blank "\n")) "%>")))
(with-temp-buffer
(insert template)
(goto-char (point-min))
(while (re-search-forward rx nil t)
(let* ((var-found (match-string 1))
(value-found (or (plist-get plist (intern var-found)) nil))
(var-plist (if value-found (plist-get plist (intern var-found)) nil)))
(if (and var-found value-found var-plist)
(replace-match (xml-escape (format "%s" var-plist)) nil nil)
(replace-match ""))))
;;(replace-match (concat "<% " var-found " %>") nil nil))))
(let ((rx (rx "<%=" (one-or-more (or blank "\n")) "@var" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "%>")))
(goto-char (point-min))
(while (re-search-forward rx nil t)
(let* ((var-found (match-string 1))
(value-found (or (plist-get plist (intern var-found)) nil))
(var-plist (if value-found (plist-get plist (intern var-found)) nil)))
(if (and var-found value-found var-plist)
(replace-match (format "%s" var-plist) nil nil)
(replace-match ""))))
;; (replace-match (concat "<% " var-found " %>") nil nil))))
(let ((rx2 (rx "<%" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "%>")))
(goto-char (point-min))
(while (re-search-forward rx2 nil t)
(let* ((var-found (match-string 1))
(value-found (or (plist-get plist (intern var-found)) nil))
(var-plist (if value-found (or (plist-get plist (intern var-found)) (concat "<% " var-found " %>")))))
(if (and var-found value-found)
(replace-match (format "%s" var-plist) nil nil)
(replace-match (concat "<% " var-found " %>" nil nil)))))
(buffer-string))))))
;; ;; (rcd/expand-<%template%>-plist "<!DOCTYPE html>
;; <html itemscope itemtype=\"http://schema.org/Article\" lang=\"<%= @var language %>\">
;; <head>
;; <meta charset=\"utf-8\">
;; <meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\"/>
;; <title><%= @var subject -escape xml%></title>
;; <meta name=\"viewport\" content=\"width=device-width\">
;; </head>
;; <style type=\"text/css\">
;; p {
;; font-size: 1.2em;
;; margin-bottom: 10;
;; margin-top: 0;
;; line-height: 1.5em;
;; }
;; </style>
;; </head>
;; <body>
;; <article style=\"color:#000; background-color:#fff; font-family:Verdana,Arial,tahoma,monospace,sans,sans-serif; font-size:16px; line-height: 1.5em;\">
;; <%= @var body %>
;; <br style=\"clear: both;/\">
;; </article>
;; <!-- <%= @var people_id %> -->
;; <footer style=\"font-size: small;\">
;; <p><small><%= @var accounts_name %>, <%= @var accounts_billingaddress %>, <%= @var accounts_billingcity %>, <%= @var accounts_billingstate %> <%= @var accounts_billingpostalcode %>, <%= @var accounts_billingcountry %> - <a href=\"<%= @var unsubscribe-url %>\"><%= @var unsubscribe-text %></a></small></p>
;; </footer>
;; </body>
;; </html>
;; " variables)
;; (string-match (rx "<%" (one-or-more (or blank "\n")) "@var" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (group (or (and (one-or-more (or blank "\n")) "-escape" (one-or-more (or blank "\n"))) (one-or-more (or blank "\n")))) "%>") "<% @var some -escape %>")
(defun rcd/expand-<%template%>-alist-1 (template alist)
"Expands the template that contains <% var %> with alist keys and values from alist"
(let ((rx (rx "<%" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "-escape" (one-or-more (or blank "\n")) "%>")))
(with-temp-buffer
(insert template)
(goto-char (point-min))
(while (re-search-forward rx nil t)
(let* ((var-found (match-string 1))
(value-found (or (alist-get (intern var-found) alist) nil))
(var-alist (if value-found (alist-get (intern var-found) alist) nil)))
(if (and var-found value-found var-alist)
(replace-match (xml-escape var-alist) nil nil)
(replace-match (concat "<% " var-found " %>") nil nil))))
(let ((rx2 (rx "<%" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more (or (any alpha) "-" "_")))) (one-or-more (or blank "\n")) "%>")))
(goto-char (point-min))
(while (re-search-forward rx2 nil t)
(let* ((var-found (match-string 1))
(value-found (or (alist-get (intern var-found) alist) nil))
(var-alist (if value-found (or (alist-get (intern var-found) alist) (concat "<% " var-found " %>")))))
(if (and var-found value-found)
(replace-match var-alist nil nil)
(replace-match (concat "<% " var-found " %>" nil nil)))))
(buffer-string)))))
;; (rcd/expand-<%template%> "<title><% (gold-price-kg) %></title> {<% @var title-some %>} {<% @var title-some %>}" '(title-some "N\"ew"))
(defun rcd/expand-<%template%>-eval (template)
(let ((rx (rx "<%" (one-or-more (or blank "\n")) (group (minimal-match (one-or-more anything))) (one-or-more (or blank "\n")) "%>")))
(with-temp-buffer
(insert template)
(goto-char (point-min))
(while (re-search-forward rx nil t)
(let* ((eval-found (match-string 1))
(eval-value (condition-case nil (eval (car (read-from-string eval-found))) (error "")))
(eval-value (if eval-value (format "%s" eval-value) "")))
(if eval-found
(replace-match eval-value nil nil)
(replace-match "" nil nil))))
(buffer-string))))
(defun rcd/expand-<%template%> (template plist)
"Expands <% templates %> with plist, global variables and any functions"
(let* ((plist (rcd/expand-<%template%>-plist template plist))
(eval (rcd/expand-<%template%>-eval plist)))
eval))
(defun rcd-xournalpp-open (file)
(when (rcd-which "xournalpp")
(async-start-process "Xournalpp" "xournalpp" 'ignore file)))
(defun rcd-ask (list)
"Ask user for LIST of choices.
If only one element, function `y-or-n-p' will be used.
For multiple elemenets `completing-read' is used.
If nothing chosen it will return empty string."
(let ((completion-ignore-case t))
(cond ((length= list 1) (if (y-or-n-p (nth 0 list)) (nth 0 list) ""))
(t (completing-read "Choice: " list nil t)))))
(defun rcd-edit-with-external-editor (&optional text)
"Editing with external editor as defined in `rcd-external-editor'.
It will either edit the optional TEXT as string
argument. Otherwise it will edit the current buffer and replace
it with the result."
(interactive)
(let* ((buffer-or-text (if text nil t))
(text (if buffer-or-text (buffer-substring-no-properties (point-min) (point-max)) text))
(point (point))
;; (mode major-mode)
(file (concat (or (getenv "TMPDIR") "/tmp/") "temp-file")))
(string-to-file-force text file)
(call-process rcd-external-editor nil nil nil file)
(if buffer-or-text
(progn
(erase-buffer)
(insert-file-contents file)
(goto-char point))
(file-to-string file))))
;;;; ↝ LIST FUNCTIONS
(defun list-of-strings-to-string (list)
"Returns string from list of strings"
(mapconcat 'identity list ""))
(defun list-has (needle haystack)
"Returns elements of haystack that contain needle, case insensitive"
(let ((found))
(while (and needle haystack)
(let ((element (pop haystack)))
(when (string-match needle (format "%s" element))
(when (not (member element found))
(push element found)))))
found))
;; (defun list-has (needle haystack)
;; "Returns elements of haystack that contain needle, case insensitive
;; Improvement by tomas@tuxteam.de on help-gnu-emacs mailing list
;; 2020-10-18 23:59. "
;; (seq-filter (lambda (elt) (string-match-p needle elt)) haystack))
(defun list-has-elements (needles haystack)
"Returns elements of haystack that contain needle, case insensitive"
(if needles
(let* ((needle (pop needles))
(haystack (list-has needle haystack)))
(list-has-elements needles haystack))
haystack))
;; (defun list-has-elements (needles haystack)
;; "Returns elements of haystack that contain needle, case insensitive
;; Improvement by tomas@tuxteam.de on help-gnu-emacs mailing list
;; 2020-10-18 23:59. "
;; (seq-reduce
;; (lambda (red-haystack needle) (list-has needle red-haystack))
;; needles
;; haystack))
;; (list-has-elements '("Em" "ma") '("Emacs" "Funny" "Hole" "Whole"))
(defun next-circular-list-item (list previous-item)
"Return the next element in the LIST by looking at PREVIOUS-ITEM.
All elements in the LIST have to be different.
If last element of LIST is equal to PREVIOUS-ITEM then first element is returned."
(let ((last-element (car (last list))))
(cond ((eq last-element previous-item) (car list))
(t (nth 1 (member previous-item list))))))
(defun file-to-list (file)
"Return a list of lines of a file"
(with-temp-buffer
(insert-file-contents file)
(split-string (buffer-string) "\n" t)))
(defun list-to-file (list file)
"Prints list into file"
(with-temp-buffer
(while list
(insert (concat (pop list) "\n")))
(write-region (point-min) (point-max) file)))
(defun list-append-first-to-first-cons (list)
"cons with first-elt . first-elt"
(mapcar (lambda (item) (cons item item)) list))
(defun list-joined-with-format-and-separator (format list separator)
(mapconcat 'identity (mapcar (lambda (item) (format format item)) list) separator))
(defun list-append-elts-to-first-cons (list)
"Cons with FIRST-ELT . FIRST-ELT OTHER-ELT"
(mapcar (lambda (item) (cons (car item) (list item))) list))
(defun iota (count &optional start step)
"Return a list containing COUNT numbers, starting from START
and adding STEP each time. The default START is 0, the default
STEP is 1"
(let* ((start (if start start 0))
(step (if step step 1))
(counter 0)
(list '())
(elt start))
(while (< counter count)
(push elt list)
(setq elt (+ elt step))
(setq counter (1+ counter)))
(reverse list)))
;;;; ↝ HASH FUNCTIONS
(defun hash-to-plist (hash)
"Convert hash HASH to plist."
(let (plist)
(maphash (lambda (key value) (push key plist) (push value plist)) hash)
(reverse plist)))
(defun hash-to-alist (hash)
"Convert hash HASH to alist"
(let (alist)
(maphash (lambda (key value) (push (cons key value) alist)) hash)
alist))
(defun hash-to-list (hash)
"Convert hash HASH to list"
(let (list)
(maphash (lambda (key value) (setq list (append list (list (list key value))))) hash)
list))
(defun hash-append (h1 &rest hashes)
"Return H1 hash appende with HASHES."
(mapc
(lambda (hash)
(maphash
(lambda (key value) (puthash key value h1)) hash))
hashes)
h1)
;;;; ↝ VECTOR FUNCTIONS
(defun vector-to-list (vector)
"Returns list from VECTOR."
(append vector '()))
;;;; ↝ NUMBER FUNCTIONS
(defun random-number (&optional digits)
"Returns the random number with 6 digits by default"
(let ((digits (if digits digits 6))
(count 0))
(string-to-number
(with-output-to-string
(while (/= count digits)
(princ (number-to-string (1+ (random 9))))
(setq count (1+ count)))))))
;;;; Published 2020-10-13;; TODO publish again
(defun clisp-number-to-words (n &optional trim)
"Returns the cardinal English number representation, for example if N is 4, it would return \"four\""
(clisp (format "(format t \"~R\" %d)" n) trim))
(defun perl (string)
(if (rcd-which "perl")
(if string
(rcd-command-output-from-input "perl" string)
"")
(rcd-warning-message "RCD ERROR: `perl' not found in $PATH")))
(defun clisp (data &optional trim)
(if (rcd-which "clisp")
(let* ((value (if data
(rcd-command-output-from-input "clisp" data "-q" "-norc" "-")
""))
(value (if trim (string-trim value) value)))
value)
(rcd-warning-message "RCD ERROR: `clisp' not found in $PATH")))
(defmacro clisp-macro (&rest body)
(declare (indent 1) (debug t))
`(clisp (prin1-to-string (quote ,@body)) t))
;;;; ↝ SQL FUNCTIONS
(defun sql-number-or-null (number)
(cond ((numberp number) number)
((null number) "NULL")))
(defun sql-escape-string (str &optional trim)
"Returnes escaped string for PostgreSQL. If string is `NULL' returns `NULL'"
(if (null str)
(setq str "NULL")
(when (or (string-match "\\\\" str)
(string-match "'" str))
(setq str (replace-regexp-in-string "\\\\" "\\\\\\\\" str))
(setq str (replace-regexp-in-string "'" "''" str))))
(unless (string= "NULL" str)
(setq str (format "E'%s'" str)))
(if trim
(string-trim str)
str))
(defun psql-age (date)
"Returns age from given DATE by using external command `psql'"
(if (rcd-which-list '("psql"))
(let* ((date (shell-command-to-string (format "psql -Stc \"SELECT age(date('%s'))\"" date)))
(date (string-trim date))
(date (replace-regexp-in-string "mon" "month" date)))
date)
(rcd-warning-message "RCD ERROR: `psql' not found in $PATH")))
(defun rcd-sql-prepare-text-query (query)
(if (string-match " " query)
(let* ((query (string-trim query))
(query (if (and (string-match " " query)
(not (string-match "&" query)))
(string-replace " " " & " query)
query)))
query)
query))
(defun rcd-sql-id-list (list)
(string-join
(mapcar #'number-to-string list)
", "))
;;;; ↝ BUFFER FUNCTIONS
(defun rcd-highlight-list (list)
"Uses LIST to highlight strings in buffer."
(hi-lock-mode)
(let* ((list (delete "" list))
(highlights hi-lock-face-defaults))
(while list
(highlight-regexp (regexp-quote (pop list)) (pop highlights)))))
(defun pop-buffer-highlight-elements (query list buffer &optional trim)
"Pops buffer, inserts lines from a list and highlights queried elements"
(let ((query (if (listp query) query (list query)))
(buffer (get-buffer-create buffer)))
(pop-to-buffer buffer)
(local-set-key "q" 'quit-window)
(read-only-mode 0)
(erase-buffer)
(while list
(let* ((line (pop list))
(line (if trim (string-trim line) line)))
(insert line)
(insert "\n")))
(while query
(highlight-phrase (pop query)))
(read-only-mode 1)))
(defvar rcd-word-processing t
"Invokes margins and ruler")
(defun rcd-word-processing ()
"Sets margins around `fill-column' and invokes `ruler-mode'"
(interactive)
(let ((fill-column 88)
(width (window-total-width)))
(when (> width fill-column)
(let* ((left (/ (- width fill-column 2) 3))
(right (- width left fill-column 3)))
(set-window-margins (get-buffer-window) left right)
(setq left-margin-width left)
(setq right-margin-width right)))
(auto-fill-mode 1)
(toggle-tool-bar-mode-from-frame 1)
(ruler-mode)))
(defun rcd-read-from-minibuffer-without (without-list prompt &optional initial-contents keymap read hist default-value inherit-input-method)
"Do same as `read-from-minibuffer' while excluding input with
strings in the list WITHOUT-LIST."
(let ((output)
(without-list (mapcar (lambda (item) (if (stringp item) item (prin1-to-string item))) without-list)))
(while (list-has-elements
without-list
(split-string
(setq output (read-from-minibuffer prompt initial-contents keymap read hist default-value inherit-input-method)))))
(message output)))
(defun read-from-buffer (&optional value buffer-name mode title keymap place)
"Edits string and returns it"
(let ((this-buffer (buffer-name))
(title (or title ""))
(value (or value ""))
(new-value value)
(point (cond ((numberp place) place)
((listp place) (cdr (assoc "place" place)))))
(table (when (listp place) (cdr (assoc "table" place))))
(column (when (listp place) (cdr (assoc "column" place))))
(table-id (when (listp place) (cdr (assoc "table-id" place))))
(_ (message "EDIT %s" place))
(_ (message "%s" place))
(read-buffer (if buffer-name
(generate-new-buffer buffer-name)
(generate-new-buffer "*edit-string*"))))
(save-excursion
(switch-to-buffer read-buffer)
(erase-buffer)
(set-buffer read-buffer)
(if mode
(if (fboundp mode)
(funcall mode)
(rcd-message "You need `%s' mode" (symbol-name mode)))
(text-mode))
(setq rcd-current-table table)
(setq rcd-current-column column)
(setq rcd-current-table-id table-id)
;; (local-set-key (kbd "C-c C-c") 'exit-recursive-edit)
(local-set-key (kbd "<f8>") 'exit-recursive-edit)
(setq header-line-format (format "%s ➜ Finish editing with or C-M-c or F8" title))
(when keymap
(use-local-map keymap))
(when rcd-word-processing
(rcd-word-processing))
(if (stringp value) (insert value))
(goto-char (or point (point-min)))
(speak "You may quit the buffer with Meta Control C")
(message "When you're done editing press C-M-c or F8 to continue.")
(setq eval-expression-debug-on-error nil)
(unwind-protect
(recursive-edit)
(if (get-buffer-window read-buffer)
(progn
(setq new-value (buffer-substring (point-min) (point-max)))
(kill-buffer read-buffer))))
(setq eval-expression-debug-on-error t)
(switch-to-buffer this-buffer)
new-value))) ;; TODO if mode is used, maybe it should not return propertized string
;;;; ↝ SPEECH FUNCTIONS
;;; TODO make it defcustom, set some defaults
(defvar rcd-speech-function 'identity "The function that handles strings to be spoken")
(defvar rcd-speech t "If TRUE the RCD programs will enable speech")
(defvar rcd-festival-function 'festival-say-string "Which festival function to be called")
(setq rcd-speech-function 'rcd-speak-festival)
(defun speak (string)
"Returnes speech by using RCD-SPEAK-FUNCTION"
(funcall rcd-speech-function string))
(defun rcd-speak-festival (string)
"Returns speech by using festival if the `rcd-speech' variables
is true and `festival-program-name' has some value"
(if (and rcd-speech (bound-and-true-p festival-program-name))
(funcall rcd-festival-function string)))
;;;; ↝ TEXT FUNCTIONS
(defun rcd-enclose-region (open close)
"Embrace region with OPEN and CLOSE."
(interactive)
(save-excursion
(goto-char (region-beginning))
(insert open))
(insert close))
(defvar rcd-enclose-region-ask-history nil)
(defun rcd-enclose-region-ask (open close)
(interactive)
(if (region-active-p)
(rcd-enclose-region open close)
(let* ((prompt (format "%sEnter input%s: " open close))
(word (read-from-minibuffer prompt nil nil nil 'rcd-enclose-region-ask-history nil t)))
(insert open)
(insert word)
(insert close))))
(defun rcd-markdown-tag (type)
(cond ((eq 'strong type) '("*" "*"))
((eq 'italic type) '("_" "_")))) ;; TODO
(defun rcd-markup-tags-by-mode ()
(cond ((eq 'markdown-mode major-mode) 'rcd-markdown-tag)
((eq 'adoc-mode major-mode) 'rcd-asciidoc-tag)))
(defun rcd-bracket-region-heavy-angle-bracket-ornaments ()
(interactive)
(rcd-enclose-region-ask "❰" "❱"))
(defvar rcd-html-tag-history nil)
(defun rcd-html-tag ()
(interactive)
(let* ((tag (read-from-minibuffer "Tag: " (car rcd-html-tag-history) nil nil 'rcd-html-tag-history nil t))
(open (format "<%s>" tag))
(close (format "</%s>" tag)))
(rcd-enclose-region-ask open close)))
(defvar rcd-markup-tag-history nil)
(defun rcd-markup-tag ()
(interactive)
(let* ((tag (read-from-minibuffer "Tag: " (car rcd-markup-tag-history) nil nil 'rcd-markup-tag-history nil t)))
(rcd-enclose-region-ask tag tag)))
(defun rcd-html-strong ()
(interactive)
(rcd-enclose-region-ask "<strong>" "</strong>"))
(defun rcd-tag-sql-coalesce ()
(interactive)
(rcd-enclose-region "coalesce(" ",'')"))
(defun text-alphabetic-only (text)
"Return alphabetic characters from TEXT."
(replace-regexp-in-string "[^[:alpha:]]" " " text))
(defun rcd-word-frequency (text &optional length)
"Returns word frequency as hash from TEXT.
Words smaller than LENGTH are discarded from counting."
(let* ((hash (make-hash-table :test 'equal))
(text (text-alphabetic-only text))
(length (or length 3))
(words (split-string text " " t " "))
(words (mapcar 'downcase words))
(words (mapcar (lambda (word) (when (> (length word) length) word)) words))
(words (delq nil words)))
(mapc (lambda (word)
(puthash word (1+ (gethash word hash 0)) hash))
words)
hash))
(defun rcd-word-frequency-list (text &optional length)
"Return the unsorted word frequency list of pairs.
First item of the pair is the word, second the word count.
It will analyze TEXT, with minimum word LENGTH."
(let* ((words (rcd-word-frequency text length))
(words (hash-to-list words))
(frequent (seq-sort (lambda (a b)
(> (cadr a) (cadr b)))
words)))
frequent))
(defun rcd-word-frequency-string (text &optional length how-many)
"Return string with most frequent words in TEXT.
Use LENGTH to designate minimum length of words to analyze.
Return HOW-MANY words"
(let ((frequent (rcd-word-frequency-list text length)))
(mapconcat (lambda (a) (car a)) (butlast frequent (- (length frequent) how-many)) " ")))
(defun rcd-word-frequency-buffer (&optional how-many)
(interactive)
(let* ((how-many (or how-many (read-number "How many most frequent words you wish to see? ")))
(text (buffer-string))
(frequent (rcd-word-frequency-list text))
(report (mapconcat (lambda (a) (format "%s:%s " (car a) (cadr a))) (butlast frequent (- (length frequent) how-many)) " ")))
(prog1
report
(message report))))
(defun insert-= (times)
"Returns = as string for number of times"
(let ((count 0))
(while (<= count times)
(insert "=")
(setq count (1+ count)))))
;;;; ↝ MISCELLANEOUS FUNCTIONS
(defun split-attribute-colon-value (item)
"TODO"
(let* ((split (split-string item ":"))
(attribute (car split))
(attribute (string-trim attribute))
(attribute (replace-regexp-in-string " " "-" attribute))
(value (cadr split))
(value (if value (string-trim value) nil)))
(list attribute value)))
(defun last-key ()
"Returns the last pressed key"
(let ((keys (recent-keys)))
(car (append (reverse keys) '()))))
;;;; ↝ LISP DATA FUNCTIONS
(defun string-to-file-force (string file)
"Prints string into file, matters not if file exists. Returns FILE as file name."
(with-temp-file file
(insert string))
file)
(defun file-to-string (file)
"File to string function"
(with-temp-buffer
(insert-file-contents file)
(buffer-string)))
(defun data-to-file (data file)
"PRIN1 Emacs Lisp DATA to FILE"
(string-to-file-force (prin1-to-string data) file))
(defun data-from-file (file)
"Reads and returns Emacs Lisp data from FILE"
(car
(read-from-string
(file-to-string file))))
(defun rcd-save-symbol-to-file (&optional symbol)
"Save SYMBOL to file"
(interactive)
(let ((symbol (or symbol (read--expression "Symbol value to save: ")))
(file (read-file-name "File name: ")))
(data-to-file (symbol-value symbol) file)))
(defun rcd-read-symbol-from-file (&optional symbol)
"Read SYMBOL from file"
(interactive)
(let ((symbol (or symbol (read--expression "Symbol value to read: ")))
(file (read-file-name "File name: ")))
(eval `(defvar ,symbol ,(data-from-file file)))))
;;;; ↝ FILE FUNCTIONS
(defun count-files-in-directory (dir)
"Return number of files in DIR directory."
(length (directory-files dir nil "[[:alnum:]]" t)))
(defun three-parent-dirs (path)
"Returns three parent directors of a full file path or NIL"
(let* ((without-file (file-name-directory path)))
(if (string= path without-file) nil
(let* ((split (reverse (butlast (split-string without-file "/")))))
(if (<= (length split) 3) nil
(nthcdr (- (length split) 3) (reverse split)))))))
(defun rcd-normalize-files ()
(interactive)
(let ((files (directory-files-recursively default-directory "")))
(while files
(let ((file (pop files)))
(cond ((file-directory-p file) (chmod file 493))
(t (chmod file 420)))))))
(defun parent-dir (path)
"Returns the parent directory of a full file path or NIL"
(file-name-base (slash-remove path)))
;; (let* ((without-file (file-name-directory path)))
;; (if (string= path without-file) nil
;; (let* ((split (reverse (butlast (split-string without-file "/")))))
;; (concat "/" (string-join (butlast (reverse (butlast split))) "/") "/")))))
(defun mkdatedir (&optional directory)
"Creates new directory according to date, if optional argument
`directory' is specified, then new date directory is created
inside of the existing directory."
(interactive)
(let ((date (format-time-string "%Y-%m-%d"))
(directory (or directory default-directory)))
(if dired-directory
(progn
(mkdir date)
(revert-buffer))
(if (and directory (file-directory-p directory))
(progn
(mkdir (concat (file-name-as-directory directory) date)))))))
;;;; ↝ MENU FUNCTIONS
(defun rcd-multiple-choice-by-list (list rcd-function &optional prompt description quit-on-any)
"Run RCD-FUNCTION on results of multiple choice LIST of strings.
It uses `q' char to quit thus its value will not be used.
PROMPT is optional just as DESCRIPTION."
(let* ((prompt (or prompt "Choose: "))
(choices '((?q "Quit")))
(key ?A)
(quit))
(mapc (lambda (item)
(when (= key ?q) (setq key (1+ key)))
(push (list key item description) choices)
(setq key (1+ key)))
(seq-sort 'string< list))
(while (not quit)
(let* ((selection (read-multiple-choice prompt (reverse choices)))
(new-key (car selection))
(value (cadr selection)))
(setq key new-key)
(when (or quit-on-any (= 113 key)) (setq quit t))
(unless (= 113 new-key)
(funcall rcd-function value))))))
;;;; ↝ UNDERLINING AND COMMENTING FUNCTIONS
(defun rcd-emacs-lisp-heading (text)
(interactive "sText: ")
(insert ";;;; ↝ ")
(insert (upcase text))
(insert "\n"))
(defvar commented-heading-char nil)
(defun commented-heading (text)
(interactive "sText: ")
(let* ((text (upcase text))
(padding 2)
(comment-length 4)
(comment-length (if current-prefix-arg
(read-number "Comment length: " 4)
comment-length))
(comment-char (if current-prefix-arg
(read-char "Char for comment: ")
(or commented-heading-char 59)))
(comment (make-string comment-length comment-char))
(length (+ (* 2 padding) (length text)))
(line (format "%s %s\n" comment (make-string length #x2501)))
(heading (format "%s %s\n" comment text)))
(setq commented-heading-char comment-char)
(insert line)
(insert heading)
(insert line)))
(defun heading-underlined ()
"Asks for title and underlines it"
(interactive)
(let* ((heading (read-from-minibuffer "Heading:"))
(heading (upcase heading))
(l (length heading)))
(insert heading)
(insert ":\n")
(insert-= l)
(insert "\n")))
(defun underline-text (text &optional no-newlines)
"Asks for TEXT and returns it underlined. If optional
NEW-NEWLINES is true, it will not add new lines."
(let* ((l (length text))
(newlines (if no-newlines "" "\n\n")))
(format "%s\n%s%s" text
(with-output-to-string
(let ((count 0))
(while (< count l)
(princ "=")
(setq count (1+ count)))))
newlines)))
(defun underline-text-interactive (text)
"Underlines and insert text into buffer"
(interactive "sText: ")
(insert (underline-text text)))
;;;; ↝ EXTERNAL PROGRAMS
(defun pdfinfo (file)
"Returns a list containing `pdfinfo' information"
(if (rcd-which-list '("pdfinfo"))
(let* ((info (call-process-to-string "pdfinfo" nil nil file))
(list (split-string info "\n"))
(nlist '()))
(while list
(let* ((item (pop list))
(result (split-attribute-colon-value item))
(attribute (car result))
(attribute (downcase attribute))
(la (length attribute))
(value (cadr result)))
(if (> la 0)
(setq nlist (plist-put nlist (intern attribute) value)))))
nlist)
(rcd-warning-message "RCD ERROR: `pdfinfo' not found in $PATH")))
(defun rcd-mime-type (file)
"Returns mime type of the file"
(if (rcd-which-list '("file" "mimetype"))
(let ((file-command (executable-find "file"))
(mimetype (executable-find "mimetype")))
;; TODO:
;; There is much work to do here to work on various systems for
;; example there may not be same output on BSD and GNU systems.
;; Additional problem is file quoting.
;; file and mimetype may give different results
(if file-command
(string-trim
(call-process-to-string file-command nil nil "-b" "--mime-type" file))
(if mimetype
(string-trim
(call-process-to-string mimetype nil nil "-b" file)))))
(rcd-warning-message "RCD ERROR: `file' or/and `mimetype' not found in $PATH")))
(defun image-mime-type-p (file)
"Determines if mime type is image"
(let ((mime-type (rcd-mime-type file)))
(if (string-match "image" mime-type) file nil)))
(defun shell-escaped-file-name (s)
(concat "\"" (replace-regexp-in-string "\"" "\\\\\"" s) "\""))
(defun command-stream (command string &rest args)
(with-temp-buffer
(let* ((process (apply 'start-process "PROCESS" (current-buffer) command args)))
(set-process-sentinel process #'ignore)
(process-send-string process string)
(process-send-eof process)
(process-send-eof process)
(while (accept-process-output process))
(buffer-string))))
(defun command-stream-in-out (command string &rest args)
(let* ((memory-dir (rcd-memory-dir))
(infile (concat memory-dir "command-input")))
(string-to-file-force string infile)
(with-temp-buffer
(apply 'call-process command infile (current-buffer) nil args)
(buffer-string))))
(defun call-process-to-string (program &optional infile display &rest args)
(with-temp-buffer
(apply #'call-process program infile t display args)
(buffer-string)))
(defun rcd-command-output-from-input (program input &rest args)
"Return output string from PROGRAM with given INPUT string and optional ARGS."
(let* ((output (with-temp-buffer
(insert input)
(apply #'call-process-region nil nil program t t nil args)
(buffer-string))))
output))
(defun rcd-load-file-with-sound (file)
(let ((string (file-to-string file)))
(rcd-command-output-from-input "sox" string
"-r" "44100"
"-c" "2"
"-b" "32"
"-e" "signed-integer"
"-t" "raw"
"-"
"-q"
"-d")))
;; (rcd-load-file-with-sound "rcd-db.el")
(defun rcd-browse-url (browser url &rest new-window)
(let ((browse-url-generic-program browser)
(browse-url-browser-function 'browse-url-generic))
(browse-url url new-window)))
(defun psql (sql &rest args)
(let* ((sql (replace-regexp-in-string "\n" " " sql))
(out (apply 'rcd-command-output-from-input "psql" sql "-f" "-" args)))
out))
(defun psql-html (sql &rest args)
(let* ((sql (replace-regexp-in-string "\n" " " sql))
(out (apply 'rcd-command-output-from-input "psql" sql "-AHS" "-f" "-" args)))
out))
(defun psql-html-only (sql &rest args)
(let* ((sql (replace-regexp-in-string "\n" " " sql))
(out (apply 'rcd-command-output-from-input "psql" sql "-tAHS" "-f" "-" args)))
out))
(defun rcd-lightweight-markup-hyperlink (hyperlink name markup &optional title)
(let ((title (or title name)))
(cond ((string= markup "markdown") (format "[%s](%s \"%s\") " name hyperlink title))
((string= markup "asciidoc") (format "%s[%s] " hyperlink name))
((string= markup "txt2tags") (format "[%s %s] " name hyperlink)))))
(defun rcd-region-string ()
(when (region-active-p)
(let* ((region (car (region-bounds)))
(begin (car region))
(end (cdr region)))
(buffer-substring-no-properties begin end))))
(defun rcd-region-string-replace (string)
(when (region-active-p)
(let* ((region (car (region-bounds)))
(begin (car region))
(end (cdr region)))
(delete-region begin end)
(insert string))))
(defun rcd-markup-hyperlink (hyperlink name markup &optional title)
"Replace the active region with the corresponding HYPERLINK.
The HYPERLINK appears in the form corresponding to the
lightweight MARKUP language. Hyperlink NAME will be hyperlinked,
TITLE is optional."
(interactive)
(let* ((name (if (region-active-p) (rcd-region-string) name))
(link (rcd-lightweight-markup-hyperlink hyperlink name markup title)))
(rcd-region-string-replace link)))
(defun rcd-perl (program)
(if program (rcd-command-output-from-input "perl" program) ""))
(defun rcd-markdown (text)
"Markdown processing"
(if text (rcd-command-output-from-input "markdown" text) ""))
(defun rcd-pandoc-www-to-plain (www)
(if (rcd-which-list '("pandoc"))
(call-process-to-string "pandoc" nil nil "-f" "html" "-t" "plain" www)
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-pandoc-markdown (string &rest args)
"Return HTML as processed by `pandoc' markdown."
(if (rcd-which-list '("pandoc"))
(apply 'rcd-command-output-from-input "pandoc" string "-f" "markdown" "-t" "html" args)
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-pandoc-org-markdown (string &rest args)
"Return HTML as processed by `pandoc' markdown."
(if (rcd-which-list '("pandoc"))
(apply 'rcd-command-output-from-input "pandoc" string "-f" "org" "-t" "markdown" args)
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-pandoc-markdown-to-plain (string)
"Returns plain text from Markdown by using pandoc"
(if (rcd-which-list '("pandoc"))
(rcd-command-output-from-input "pandoc" string "--reference-location=block" "--reference-links" "-f" "markdown" "-t" "plain")
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-pandoc-html-to-plain (string)
"Returns plain text from HTML by using pandoc"
(if (rcd-which-list '("pandoc"))
(rcd-command-output-from-input "pandoc" string "--reference-location=block" "--reference-links" "-f" "html" "-t" "plain")
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-txt2tags-html (text)
"Returns HTML from txt2tags"
(if text
(rcd-command-output-from-input "txt2tags" (concat "\n" text) "-t" "html" "-")
""))
;; (rcd-txt2tags-html "== Hello ==")
(defun rcd-txt2tags-html-preview ()
"Preview asciidoctor"
(interactive)
(if (rcd-which-list '("txt2tags"))
(let* ((output (rcd-txt2tags-html (buffer-string)))
(output (if current-prefix-arg
(rcd-template-eval output)
output))
(file (rcd-lightweight-markup-output-to-filename output "txt2tags")))
(browse-url file))
(rcd-warning-message "RCD ERROR: Could not find `txt2tags' in $PATH")))
(defun rcd-lightweight-markup-filename (markup &optional extension)
(let* ((file (concat (slash-add (or (getenv "TMPDIR") (getenv "HOME") "/tmp/"))))
(file (concat file markup))
(extension (or extension ""))
(file (concat file extension)))
file))
(defun rcd-lightweight-markup-output-to-filename (text markup &optional extension)
(let* ((file (rcd-lightweight-markup-filename markup extension)))
(string-to-file-force text file)))
(defun rcd-asciidoctor (string &rest args)
"Returns plain text from Markdown by using pandoc"
(dlet ((wrs-processor "asciidoctor"))
(string-to-file-force string (rcd-lightweight-markup-filename "asciidoctor"))
(if (rcd-which "asciidoctor")
(apply 'rcd-command-output-from-input "asciidoctor" string "-" args)
(rcd-warning-message "RCD ERROR: Could not find `asciidoctor' in $PATH"))))
(defun rcd-lightweight-markup-preview ()
(interactive)
(cond ((string= rcd-markup-language "asciidoc") (rcd-asciidoc-preview))
((string= rcd-markup-language "asciidoctor") (rcd-asciidoctor-preview))
((eq major-mode 'adoc-mode) (rcd-asciidoctor-preview))
((eq major-mode 'markdown-mode) (rcd-markdown-preview))
((eq major-mode 't2t-mode) (rcd-txt2tags-html-preview))
((eq major-mode 'text-mode) (rcd-template-buffer-preview))
(t (warn "I don't have preview for `%s'" major-mode))))
(defun rcd-asciidoctor-preview-pdf ()
(interactive)
(if (rcd-which "asciidoctor")
(let ((file (rcd-lightweight-markup-filename "asciidoctor"))
(pdf (rcd-lightweight-markup-filename "asciidoctor" ".pdf")))
(rcd-asciidoctor-pdf file)
(if (file-exists-p pdf)
(find-file pdf)
(rcd-message "Could not open `%s'" pdf)))
(rcd-warning-message "RCD ERROR: Could not find `asciidoctor' in $PATH")))
(defun rcd-asciidoctor-pdf (file)
(let* ((file (expand-file-name file))
(pdf (concat file ".pdf")))
(call-process "/home/data1/protected/.gem/ruby/3.0.0/bin/asciidoctor-pdf" file nil nil "-o" pdf "-b" "pdf" "-")
pdf))
(defun rcd-asciidoc-preview ()
"Preview Asciidoc"
(interactive)
(if (rcd-which-list '("asciidoc"))
(let* ((output (if current-prefix-arg
(rcd-template-eval (buffer-string))
(buffer-string)))
(output (rcd-asciidoc output))
(file (rcd-lightweight-markup-output-to-filename output "asciidoc" ".html")))
(browse-url file))
(rcd-warning-message "RCD ERROR: Could not find `asciidoc' in $PATH")))
(defun rcd-asciidoctor-preview ()
"Preview asciidoctor"
(interactive)
(if (rcd-which-list '("asciidoctor"))
(let* ((output (if current-prefix-arg
(rcd-template-eval (buffer-string))
(buffer-string)))
(output (rcd-asciidoctor output))
(file (rcd-lightweight-markup-output-to-filename output "asciidoctor" ".html")))
(browse-url file))
(rcd-warning-message "RCD ERROR: Could not find `asciidoctor' in $PATH")))
(defun rcd-asciidoc (text)
"Produce PDF as processed by `asciidoc' Asciidoc converter."
(if (rcd-which-list '("asciidoc"))
(let* ((base (concat (or (getenv "TMPDIR") "/tmp/") "asciidoc"))
(file (concat base ".adoc")))
(string-to-file-force text file)
(call-process-to-string "asciidoc" nil nil "-o-" file))
(rcd-warning-message "RCD ERROR: Could not find `asciidoc' in $PATH")))
(defun rcd-a2x (text)
"Produce PDF as processed by `a2x' Asciidoc converter."
(if (rcd-which-list '("a2x"))
(let* ((base (concat (or (getenv "TMPDIR") "/tmp/") "asciidoc"))
(pdf (concat base ".pdf"))
(file (concat base ".adoc")))
(string-to-file-force text file)
(call-process "a2x" nil nil nil file)
pdf)
(rcd-warning-message "RCD ERROR: Could not find `a2x' in $PATH")))
(defun rcd-a2x-preview ()
"Preview PDF from Asciidoc"
(interactive)
(if (rcd-which-list '("a2x"))
(let* ((output (if current-prefix-arg
(rcd-template-eval output)
output))
(pdf (rcd-a2x output)))
(when (file-exists-p pdf)
(call-process rcd-external-pdf-viewer nil nil nil pdf)))
(rcd-warning-message "RCD ERROR: Could not find `a2x' in $PATH")))
(defun rcd-markdown-preview ()
"Preview Markdown"
(interactive)
(if (rcd-which-list '("markdown"))
(let* ((output (rcd-markdown (buffer-string)))
(output (if (fboundp 'rcd-template-eval)
(if current-prefix-arg
(rcd-template-eval output)
output)
output))
(file (string-to-file-force output (concat (or (getenv "TMPDIR") "/tmp/") "markdown.html"))))
(browse-url file))
(rcd-warning-message "RCD ERROR: Could not find `markdown' in $PATH")))
(defun rcd-bc (expression)
"Return result of mathematical expression by using system command `bc'."
(rcd-command-output-from-input "bc" expression))
(defun rcd-mkd2html (text &optional title author date)
"Full page Markdown processing"
(let* ((title (if title
(format "%% %s\n" title)
"% NO TITLE\n"))
(author (if author
(format "%% %s\n" author)
"% NO AUTHOR\n"))
(date (if date
(format "%% %s\n" date)
"% NO DATE"))
(header (concat title author date))
(css-line "<style> body { max-width: 90ch; line-height: 1.5; padding: 2ch; margin: auto; font-family: \"Helvetica\", \"Arial\", sans-serif; } h1,h2,h3,h4,h5,h6 { line-height: 1.2; } pre { width: 100%; margin: 2ch; padding: 1ch; background: #f5deb3; border: 2px solid #777; } pre code { tab-width: 4; color #333; } </style>")
(viewport-line "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">")
(text (concat header "\n" text)))
(rcd-command-output-from-input "mkd2html" text "-header" viewport-line "-header" css-line)))
;; background-color: #f5f5f5;
(defun rcd-which (command)
"Assumes that shell command `which' exists and uses it to
verify if COMMAND exists in user's $PATH"
(let ((which (executable-find "which")))
(if which
(let ((status (call-process which nil nil nil command)))
(if (zerop status) t nil))
(rcd-warning-message "RCD ERROR: Could not find `which' in $PATH"))))
(defun rcd-which-list (command-list)
"Verifies that list of shell commands COMMAND-LIST exist in
user's $PATH"
(let ((exist nil))
(while command-list
(let ((command (pop command-list)))
(if (executable-find command)
(setq exist t)
(progn
(setq exist nil)
(rcd-warning-message "Shell command `%s' does not exist" command)))))
exist))
(defun xclip-primary-selection ()
"Returns X primary selection"
(if (rcd-which-list '("xclip"))
(shell-command-to-string "xclip -selection primary -out"))
(rcd-warning-message "RCD ERROR: `xclip' not found in $PATH"))
(defun xclip-primary-selection-html ()
"Returns text/html X primary selection"
(if (rcd-which-list '("xclip"))
(call-process-to-string "xclip" nil nil "-t" "text/html" "-selection" "primary" "-out")
(rcd-warning-message "RCD ERROR: `xclip' not found in $PATH")))
;;;; ↝ MATHEMATICAL FUNCTIONS
(defun pct-minus (amount percent)
"Return AMOUNT decreased for PERCENT of it."
(let* ((percent (* amount percent))
(result (- amount percent)))
result))
(defun pct-plus (amount percent)
"Return AMOUNT increased for PERCENT of it."
(let* ((percent (* amount percent))
(result (+ amount percent)))
result))
(defun pct-plus-times (amount percent times)
"Return AMOUNT increased for PERCENT for number of TIMES."
(let ((n 0))
(while (/= n times)
(setq amount (pct-plus amount percent))
(setq n (1+ n)))
amount))
(defun pct-of-number-in-total (number total)
"Return the percentage that NUMBER represents in a TOTAL."
(/ number total 0.01))
(defun pct-of-number-in-total-1 (number total)
"Return the percentage that NUMBER represents in a TOTAL."
(let* ((number (+ number 0.0))
(total (+ total 0.0))
(percent (/ total 100.0))
(percentage (/ number percent 100)))
percentage))
(defun pct-list (list)
"Return list that representes percentages of values in a given LIST."
(let* ((total (apply '+ list)))
(mapcar (lambda (item) (pct-of-number-in-total item total)) list)))
;;;; ↝ ENVIRONMENT
(defun rcd-memory-dir ()
(let ((xdg-runtime-dir (getenv "XDG_RUNTIME_DIR")))
(if xdg-runtime-dir (slash-add xdg-runtime-dir)
(if (and (file-directory-p "/dev/shm")
(file-writable-p "/dev/shm"))
(slash-add "/dev/shm")))))
;;;; ↝ MEMORY FUNCTIONS
(defun kill-any (any)
(kill-new (format "%s" any))
(message "Killed: %s" any))
;;;; ↝ PROGRAMMING TOOLS
(defun rgrep-current-word-in-el-project ()
"Search with grep for the current word within my Emacs Lisp
project directory."
(interactive)
(let* ((word (current-word t))
;; (project rcd-current-project-directory)
(extension (file-name-extension (buffer-file-name)))
(fmt (format "grep --color --null -nH -ri -e \"%s\" *.%s" word extension)))
;;(cd project)
(grep fmt)))
;;;; ↝ EMACS EXTENSIONS
(defun message-any (any)
"Message anything to minibuffer"
(message "%s" (prin1-to-string any)))
;;;; ↝ DATE AND TIME FUNCTIONS
(defun rcd-date-iso-to-emacs-time (iso-date)
(let ((year (string-to-number (substring iso-date 0 4)))
(month (string-to-number (substring iso-date 5 7)))
(day (string-to-number (substring iso-date 8 10))))
(encode-time 0 0 0 day month year)))
(defun rcd-timestamp-date-time ()
"Returns the date by format YYYY-MM-DD-HH:MM:SS"
(let* ((time (decode-time))
(year (nth 5 time))
(month (nth 4 time))
(day (nth 3 time))
(hour (nth 2 time))
(minute (nth 1 time))
(second (nth 0 time)))
(format "%04.f-%02.f-%02.f-%02.f:%02.f:%02.f" year month day hour minute second)))
(defun rcd-timestamp-literate (&optional iso-date)
"Returns RCD timestamp"
(let ((emacs-time (when iso-date (rcd-date-iso-to-emacs-time iso-date))))
(if iso-date
(format-time-string "%A, %B %e %Y" emacs-time)
(format-time-string "%A, %B %e %Y, %T"))))
(defun rcd-timestamp-european ()
"Returns RCD timestamp"
(format-time-string "%e.%m.%Y"))
(defun rcd-sql-timestamp ()
"The timestamp format that may be used for Postgresql timestamps"
(format-time-string "%Y-%m-%d %T"))
(defun rcd-timestamp ()
"The timestamp without spaces"
(format-time-string "%Y-%m-%d-%T"))
(defun rcd-iso-date ()
(format-time-string "%Y-%m-%d"))
(defun rcd-insert-iso-date ()
"Insert date in ISO format."
(interactive)
(cond ((bound-and-true-p current-prefix-arg) (insert (format-time-string "%m/%d/%Y")))
(t (insert (format-time-string "%Y-%m-%d")))))
(defun rcd-sql-num-in-list (numbers-list)
"Concatenate list of numbers for SQL IN () expression."
(mapconcat (lambda (s) (number-to-string s)) numbers-list ", "))
(defun insert-timestamp-underlined ()
"Insert timestamp underlined"
(interactive)
(let* ((timestamp (format-time-string "%Y-%m-%d-%H:%M:%S"))
(length (1- (length timestamp))))
(insert timestamp)
(insert "\n")
(insert-= length)
(insert "\n")
(terpri)))
(defun rcd-read-time ()
(let* ((date (calendar-read-date))
(month (elt date 0))
(day (elt date 1))
(year (elt date 2)))
(encode-time 0 0 0 day month year)))
(defun rcd-date-dir (&optional ask-for-date)
"Returns the formatted date interactively asked"
(if ask-for-date
(format-time-string "%Y/%m/%Y-%m-%d/" (rcd-read-time))
(format-time-string "%Y/%m/%Y-%m-%d/")))
(defun rcd-date-choice (&optional ask-for-date)
"Returns the formatted date interactively asked"
(if ask-for-date
(format-time-string "%Y-%m-%d" (rcd-read-time))
(format-time-string "%Y-%m-%d")))
;;;; ↝ GRAPHICS FUNCTIONS
(defun rcd-view-image (image)
(let ((command (cond ((string-match ".webp$" image) '("vwebp" "-info"))
(t '("sxiv" "-f")))))
(call-process (car command) nil nil nil image (cadr command))))
(defun optimize-image-jpg (file &optional quality)
"Optimizes the JPG image with quality 70%"
(if (rcd-which-list '("mogrify"))
(let ((extension (file-name-extension file))
(quality (or quality "70")))
(when (string-match "\\(?:\\(?:jpe?\\|pn\\)g\\)" (downcase extension))
(message "Optimizing `%s'" file)
(call-process "mogrify" nil "-sampling-factor" "4:2:0" "-strip" "-interlace" "JPEG" "-colorspace" "RGB" "-format" "jpg" "-quality" quality file)
(message "Optimizing FINISHED for `%s'" file)))
(rcd-warning-message "RCD ERROR: `mogrify' not found in $PATH")))
(defun optimize-jpg-images-dired ()
"Optimizes JPG images inside of Dired"
(interactive)
(let ((files (dired-get-marked-files)))
(while files
(optimize-image-jpg (pop files)))
(revert-buffer)))
(defun image-resize (file &optional size)
"Resizes the JPG image with default size"
(if (rcd-which-list '("mogrify"))
(let ((extension (file-name-extension file)))
(when (or (equal (downcase extension) "jpg")
(equal (downcase extension) "png"))
(let* ((file (shell-double-quote file))
(command (format "mogrify -resize %s \"%s\"" size file)))
(message command)
(call-process-shell-command command))))
(rcd-warning-message "RCD ERROR: `mogrify' not found in `$PATH'")))
(defun image-resize-dired ()
"Resizes images"
(interactive)
(let ((files (dired-get-marked-files))
(size (read-number "Size: " *image-default-resize-size* '*image-resize-sizes*)))
(while files
(image-resize (pop files) size))
(revert-buffer)))
(defvar rcd-message-buffer "*RCD Message Buffer*"
"Default RCD Utilities message buffer.")
(defun rcd-message (format-string &rest message)
(let ((current (current-buffer)))
(get-buffer-create rcd-message-buffer)
(switch-to-buffer rcd-message-buffer)
(goto-char (point-max))
(insert
(apply 'format format-string message)
"\n")
(goto-char (point-max))
;(recenter-top-bottom 'bottom)
(switch-to-buffer current)
(apply 'message format-string message)))
;;;; ↝ SOUND FUNCTIONS
(defvar espeak-history nil)
(defvar espeak-voice "en")
(defvar espeak-amplitutde 80)
(defun espeak-word ()
"Speak word at point."
(interactive)
(let ((word (thing-at-point 'word t)))
(when word
(espeak word))))
(defun espeak-region ()
"Speak region"
(interactive)
(when (region-active-p)
(espeak (rcd-region-string))))
(defun rcd-speak (text)
(espeak text))
(defun espeak (&optional text speed)
"Speaks text by espeak"
(interactive)
(when (rcd-which "espeak")
(let* ((amplitude espeak-amplitutde)
(voice espeak-voice)
(speed (or speed 175))
(text (or text (read-from-minibuffer "Speak: " nil nil nil 'espeak-history)))
(command (format "espeak -s %s -a %s -v %s \"%s\"" speed amplitude voice text)))
(async-shell-command command))))
(defun rcd-play-sound-bg (file)
"Plays found file in background"
(if (rcd-which "play")
(when (and (file-exists-p file) rcd-speech)
(let ((title (concat "Playing " (file-name-nondirectory file))))
(async-start-process title "play" 'ignore file)))
(message "RCD ERROR: `play' not found in $PATH")))
;;;; ↝ REPORTING AND LOGGING FUNCTIONS
(defun rcd-warning-message (format-string &rest message)
"Plays a warning sound while using function `message' as
usual."
(rcd-play-sound-bg rcd-warning-message-sound-file)
(apply 'message format-string message))
(defun rcd-pop-to-report (string &optional buffer-name)
"Pop the new buffer and inserts STRING.
Quits with `q' if necessary.
BUFFER-NAME is optional.
It will destroy the buffer before display of report."
(let ((buffer (or buffer-name "*RCD Report*")))
(when (buffer-live-p (get-buffer buffer))
(kill-buffer (get-buffer buffer)))
(save-excursion
(pop-to-buffer buffer)
(insert string)
(goto-char 1)
(local-set-key (kbd "q") 'kill-current-buffer))))
;;;; ↝ WEBSITE REVISION SYSTEM FUNCTIONS
(defun wrs-xml-sitemap-block (sitemap)
(format "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">
%s
</urlset>" sitemap))
(defun wrs-xml-sitemap-url (url date-modified &optional change-frequency)
(let* ((change-frequency (when change-frequency
(format "<changefreq>%s</changefreq>\n" change-frequency)))
(snippet (format "<url>\n<loc>%s</loc>\n<lastmod>%s</lastmod>\n" url date-modified))
(snippet (if change-frequency
(concat snippet change-frequency)
snippet))
(snippet (concat snippet "</url>\n")))
snippet))
;;;; ↝ CHART FUNCTIONS
(defun rcd-r-colors (how-many)
(let* ((colors '("#000000" "#ff0000" "#ffff00" "#00ff00" "#00ffff" "#0000ff" "#9400d3" "#8b0000" "#ff6347"))
(length (length colors)))
(nthcdr (- length how-many) colors)))
(defun rcd-r-pie-chart (title labels values output-file &optional overwrite colors)
(if (= (round (apply #'+ values)) 1)
(let* ((values (mapcar #'number-to-string values))
(colors (or colors (rcd-r-colors (length values))))
(colors (mapcar #'string-to-single-quotes colors))
(colors (string-join colors ", "))
(values (string-join values ", "))
(labels (mapcar #'string-to-single-quotes labels))
(labels (string-join labels ", "))
(script (format "
# From https://www.tutorialkart.com/r-tutorial/draw-pie-chart-in-r-programming-language/
# Draw Pie Chart in R
# Get the library.
library(plotrix)
# Data for Pie chart
x = c(%s)
labels = c(%s)
colors = c(%s)
# Give the chart file a name.
png(file = \"%s\", width=800, height=800)
# Plot the chart.
pie3D(x, labels=labels, explode=0.15, height=0.20, main='%s', col=colors)
# Save the file.
dev.off()
" values labels colors output-file title)))
(if (and (file-exists-p output-file) (not overwrite))
(if (yes-or-no-p (format "Delete %s?" output-file))
(delete-file output-file)))
(string-to-file-force script "~/script")
(rcd-command-output-from-input "R" script "--vanilla")
(if (not (file-exists-p output-file))
(rcd-warning-message "File %s not created. Verify why." output-file)
(find-file output-file)))
(rcd-warning-message "The addition of values shall be equal to 1")))
;;;; ↝ MEDIA UTILITIES
(defun image-dimension (file)
"Returns list of width and height of the image"
(when (rcd-which "identify")
(let* ((dimensions (call-process-to-string "identify" nil nil "-format" "%w %h" file)))
(mapcar 'string-to-number (split-string dimensions)))))
(defun video-dimension (file)
"Returns list with of width and height of the video"
(let* ((command (format "mplayer -vo null -ao null -identify -frames 0 \"%s\" 2> /dev/null \| grep \"ID_VIDEO_WIDTH\\|ID_VIDEO_HEIGHT\"" file))
(output (shell-command-to-string command))
(output (split-string output))
(width (cadr (split-string (car output) "=")))
(height (cadr (split-string (cadr output) "="))))
(mapcar 'string-to-number (list width height))))
(defun media-dimension (file &optional mime-type)
"Returns list of width and height of the media file"
(let ((mime-type (if mime-type mime-type (rcd-mime-type file))))
(cond ((string-match "video" mime-type) (video-dimension file))
((string-match "image" mime-type) (image-dimension file))
(t (error "Did not find file type")))))
(defun media-scale (width height new-width)
"Returns the height proportional to the width
height, and based on the new width"
(let* ((width (if (numberp width) width (string-to-number width)))
(height (if (numberp height) height (string-to-number height)))
(new-width (if (numberp new-width) new-width (string-to-number new-width)))
(ratio (/ width height 1.0))
(height (truncate (float (/ new-width ratio 1.0)))))
(list new-width height)))
;;;; ↝ EVALUATION FUNCTIONS
(defun rcd-eval-visually ()
"Eval last sexp and visually insert result by using =>
expression."
(interactive)
(let* ((result (eval (elisp--preceding-sexp)))
(default-arrow "⇒")
(arrow (if (bound-and-true-p current-prefix-arg)
"\n;; evaluates to:"
default-arrow)))
(insert (format " %s %s" arrow (prin1-to-string result)))))
(rcd-notify "LOADED rcd-utilities.el" "Loaded rcd-utilities.el" "100" "emacs")
(provide 'rcd-utilities)
;;; rcd-utilities.el ends here
;; Local Variables:
;; rcd-vc-ask-for-description: nil
;; rcd-vc-ask-for-revision: nil
;; End:Source of this page
It may be interesting to see how source of this page looks like.