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-2022 Jean Louis
;; Author: Jean Louis <bugs@gnu.support>
;; Version: 2.10
;; 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 'dired)
(require 'hi-lock)
(require 'rcd-template nil t)
(require 'seq)
(require 'subr-x)
; (require 'rcd-template)
;;;; CUSTOMIZATION
(defgroup rcd nil
"Reach, Connect, Deliver customization category."
:group 'applications)
(defcustom rcd-program-name "RCD Notes"
"Default program name."
:group 'rcd
:type 'string)
(defcustom rcd-pg-function 'rcd-sql
"Default PostgreSQL function name."
:group 'rcd
:type 'function)
(defcustom rcd-sqlite-function 'rcd-sqlite
"Default SQLite function name."
:group 'rcd
:type 'function)
(defcustom rcd-database-types '("pg" "sqlite")
"RCD Notes database types."
:group 'rcd
:type 'sexp)
(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-temp-file-directory "~/tmp/"
"Temporary directory for other temporary files."
:group 'rcd
:type 'string)
(defcustom rcd-external-pdf-viewer "evince"
"The external PDF viewer for some previewing functions."
:group 'rcd
:type 'string)
(defcustom rcd-speech-function 'identity
"The function that handles strings to be spoken"
:group 'rcd
:type 'symbol)
(defcustom rcd-espeak-voice "en"
"The default language code for espeak voices."
:group 'rcd
:type 'string)
(defcustom rcd-espeak-amplitude 80
"The default espeak amplitude."
:group 'rcd
:type 'integer)
(defcustom rcd-message-active t
"Utilize `rcd-message-buffer' if TRUE."
:group 'rcd
:type 'boolean)
;;;; VARIABLES
(defvar *image-default-resize-size* 1536)
(defvar *image-resize-sizes* '())
(defvar-local rcd-tabulated-original-entries nil
"Original `tabulated-list-entries'.")
(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-return-function nil
"The function to return upon quitting.")
(put 'rcd-current-return-function 'permanent-local t)
(defvar-local rcd-tabulated-marked-items nil
"Collects IDs for tabulated list modes.")
(put 'rcd-tabulated-marked-items 'permanent-local t)
(defvar-local rcd-db-current-database-type nil
"Buffer local variable to designate the database type.")
(put 'rcd-db-current-database-type 'permanent-local t)
(defvar-local rcd-db-current-database-handle nil
"Buffer local variable to designate the database handle.")
(put 'rcd-db-current-database-handle 'permanent-local t)
(defvar-local rcd-db-current-table nil
"Buffer local variable to designate the edited database table.")
(put 'rcd-db-current-table 'permanent-local t)
(defvar-local rcd-db-current-column nil
"Buffer local variable to designate the edited database column.")
(put 'rcd-db-current-column 'permanent-local t)
(defvar-local rcd-db-current-table-id nil
"Buffer local variable to designate the edited table ID.")
(put 'rcd-db-current-table-id 'permanent-local t)
(defvar rcd-db-current-people-id nil
"Current people ID.")
(put 'rcd-db-current-people-id 'permanent-local t)
;;;; OTHER VARIABLES
(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.")
;;;; SPECIAL FUNCTIONS
(defmacro rcd-dlet (binders &rest body)
"Like `let*' but using dynamic scoping.
Argument BINDERS behaves similarly like `let' with the difference
that variables become global even under lexical scope.
Optional argument BODY will be executed."
(declare (indent 1) (debug let))
;; (defvar FOO) only affects the current scope, but in order for
;; this not to affect code after the main `let' we need to create a new scope,
;; which is what the surrounding `let' is for.
;; FIXME: (let () ...) currently doesn't actually create a new scope,
;; which is why we use (let (_) ...).
`(let (_)
,@(mapcar (lambda (binder)
`(defvar ,(if (consp binder) (car binder) binder)))
binders)
(let* ,binders ,@body)))
;;; FIND FUNCTION IN OTHER WINDOW'S BUFFER
(defun rcd-find-function-at-point-in-other-window ()
"Find function at point in other window's buffer."
(interactive)
(let ((function (thing-at-point 'symbol)))
(when function
(let* ((function (substring-no-properties function))
(definition (format "(defun %s " function)))
(when (symbol-function (intern function))
(message "`%s' is function" function)
(other-window -1)
(let ((point (point)))
(goto-char (point-min))
(cond ((search-forward definition nil t) (progn
(message "Found definition for `%s' on line `%s'"
function (line-number-at-pos))
(recenter-top-bottom 1)
(other-window -1)))
(t (progn
(goto-char point)
(other-window -1)
(message "Not found definition for `%s'" function))))))))))
;;; 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.
Optional argument ICON may be used to add nice graphics.
Optional argument URGENCY may be used.
Optional argument CATEGORY may be used.
Optional argument HINT may be used."
(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-last-part-after-space (s)
"Return last part of string S after the space."
(let ((s (string-trim s)))
(substring s (- (length s) (string-match "[[:blank:]]" (reverse s))))))
(defun string-cut-id (s)
"Return the ID number as integer from beginning of a string S.
A space must follow the ID number, without many checks.
When string S is `123 Hello there' this function will return 123."
(let* ((until (string-match " " s)))
(if until
(string-to-number (substring s nil until))
nil)))
(defun string-cut-id-with-part (s)
"Return the ID number and first part of string in a string S.
String S shall contain 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)
"Return 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-positive-integer-p (s)
"Return number only if string is positive integer, otherwise
NIL."
(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 string-is-number-p (s)
"Return number only if string is actual number, otherwise NIL."
(let* ((s (string-trim s)))
(cond ((seq-empty-p s) nil)
((string-match "[^0123456789\\.-]" s) nil)
((string-match "-" s 1) nil)
((numberp (string-to-number s)) (string-to-number s)))))
(defun rcd-string-clean-whitespace (s)
"Return trimmed string S after cleaning whitespaces."
(replace-regexp-in-string
(rx (one-or-more (any whitespace ?\n)))
" "
(string-trim s)))
(defun rcd-get-bracketed-id-end (s)
"Return 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)
"Return / 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 rcd-split-name (name)
"Return list of 3 elemnts for NAME.
List represents (list FIRST-NAME MIDDLE-NAMES LAST-NAME)."
(let* ((name (capitalize name))
(name (split-string name nil t))
(length (length name)))
(cond ((> length 3) (list (pop name) (string-join (butlast name) " ") (car (last name))))
((= length 3) (list (pop name) (pop name) (pop name)))
((= length 2) (list (pop name) nil (pop name)))
((= length 1) (list nil nil (pop name)))
(t (list nil nil nil)))))
(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)
"Return 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)
"Downcase string S, even if nil.
It is 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-words-to-double-quotes (s)
(let* ((split (split-string s " " t))
(joined (mapconcat 'string-to-double-quotes split " ")))
joined))
(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)
"Return T if string is empty or NIL"
(let ((s (if (null s) "" s)))
(if (stringp s)
(if (zerop (length s)) nil t))))
(defun rcd-string-is-really-not-empty-p (s)
"Return TRUE if string is really not empty."
(let* ((s (rcd-string-clean-whitespace s))
(s (string-trim s)))
(rcd-string-not-empty-p s)))
(defun string-blank-if-nil (s)
"Return blank string for nil values"
(if (null s) "" s))
(defun string-or-empty-string (i)
"Return 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)
"Return string from N even if N is nil."
(cond ((null n) "")
((stringp n) n)
(t (number-to-string n))))
(defun number-or-nil-to-string (n)
"Return NIL if N is NIL, otherwise proceed with `number-to-string' function."
(cond ((null n) nil)
(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)
"Return 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-geoiplookup (ip)
"Return possible country for IP."
(if (rcd-which "geolookup")
(string-trim
(call-process-to-string "geoiplookup" nil nil ip))
(rcd-warning-message "RCD ERROR: `geolookup' not found in $PATH")))
(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 rcd-gpg-encrypt (string receiver)
"Return the GnuPG STRING encrypted to RECEIVER."
(if (rcd-which "gpg")
(rcd-command-output-from-input "gpg" string "-e" "-a" "-r" receiver)
(rcd-warning-message "RCD ERROR: `gpg' not found in $PATH")))
(defun rcd-variable-toggle-global (symbol)
"Toggle value of SYMBOL as TRUE or FALSE.
SYMBOL is expected to be global to the function."
(cond ((boundp symbol)
(cond ((eq (symbol-value symbol) t)
(set symbol nil))
((eq (symbol-value symbol) nil)
(set symbol t)))
(symbol-value symbol))
(t (user-error "Cannot toggle non-global variable `%s'" symbol))))
(defun rcd-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 (rcd-ask "(setq VARIABLE: "))
(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))
;;; KILLING THINGS
(defun rcd-kill-word ()
(interactive)
(let ((thing (thing-at-point 'word)))
(when thing
(prog2
(rcd-message "Killed `%s'" thing)
(kill-new thing)))))
;;; 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)
"Return 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)))
;;;; TEMPORARY FILES
(defun rcd-temp-file-name (&optional file-name extension)
"Return temporary file name."
(concat (file-truename (file-name-as-directory rcd-temp-file-directory))
(or file-name (format-time-string "%A-%B-%d-%Y-%H-%M-%S"))
"."
(or extension "txt")))
(defun rcd-temp-directory-name (&optional directory-name)
"Return temporary directory name."
(let ((name (concat (file-name-as-directory (or (getenv "TMPDIR") "/tmp/"))
"temp-dirs/"
(file-name-as-directory (or directory-name (format-time-string "%A-%B-%d-%Y-%H-%M-%S"))))))
name))
;;;; 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 %>.
PLISt with its member values expand into variables."
(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))))))
(defun rcd/expand-<%template%>-alist-1 (template alist)
"Expands the template that contains <% var %>.
Expansion takes place with 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)))))
(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-choose (list &optional prompt predicate initial-input def)
"Ask user for LIST of choices.
If only one element, function `y-or-n-p' will be used.
For multiple elements `completing-read' is used.
If nothing chosen it will return empty string."
(let* ((completion-ignore-case t)
(prompt (or prompt "Choose: "))
(description (format "History for `%s' completion prompt." prompt))
(history (rcd-symbol-if-not-exist (concat "rcd-" prompt "-history") nil description))
(input (cond ((length= list 1) (if (y-or-n-p (nth 0 list)) (nth 0 list) ""))
(t (rcd-repeat-until-not-empty-string 'completing-read prompt list predicate t initial-input history def t)))))
input))
(defun rcd-sql-y-or-n-p (&optional prompt)
"Return \"TRUE\" for \"y\" and \"FALSE\" for \"n\"."
(let* ((prompt (or prompt "TRUE (yes) or FALSE (no)? "))
(boolean (y-or-n-p prompt)))
(cond ((null boolean) "FALSE")
(t "TRUE"))))
(defun rcd-ask (&optional prompt initial-input default-value auto-initial-input)
"Modified function `read-string'.
This is shorter, simpler function that generates the prompt
automatically, generates history variable automatically and
inherits the input method. The input will be returned trimmed."
(let* ((prompt (or prompt "Input data: "))
(history (rcd-ask-history-variable prompt))
(initial-input (cond (auto-initial-input (car (symbol-value history)))
(initial-input initial-input)))
(input (read-string prompt initial-input history default-value t))
(input (string-trim input)))
input))
(defun rcd-ask-number (&optional prompt default-value)
"Modified function `read-number'.
This is shorter, simpler function that generates the prompt
automatically, generates history variable automatically."
(let* ((prompt (or prompt "Input number: "))
(history (rcd-ask-history-variable prompt))
(input (read-number prompt default-value history)))
input))
(defun rcd-ask-get (&optional prompt initial-input default-value auto-initial-input)
"Return non-empty result from function `rcd-ask'."
(rcd-repeat-until-something 'rcd-ask prompt initial-input default-value auto-initial-input))
(defun rcd-ask-default (&optional prompt initial-input default-value auto-initial-input)
"Run function `rcd-ask' but return DEFAULT-VALUE in case of empty string."
(let ((result (rcd-ask prompt initial-input default-value auto-initial-input)))
(cond ((string-empty-p result) default-value)
(t result))))
(defun rcd-ask-or-null (&optional prompt initial-input default-value auto-initial-input)
"Run function `rcd-ask' but return NIL if result is empty string."
(let ((result (rcd-ask prompt initial-input default-value auto-initial-input)))
(if (string-empty-p result) nil result)))
(defun rcd-ask-sql-or-null (&optional prompt initial-input default-value auto-initial-input)
"Return SQL escaped result or \"NULL\" if empty string."
(let ((result (rcd-ask prompt initial-input default-value auto-initial-input)))
(cond ((string-empty-p result) "NULL")
(t (sql-escape-string result)))))
(defun rcd-ask-times (times &optional prompt initial-input default-value)
"Return list of queries by multiples TIMES"
(let ((list ())
(count 0))
(while (< count times)
(push (rcd-ask (concat (format "[#%s] " (1+ count)) prompt) initial-input default-value) list)
(setq count (1+ count)))
list))
(defun rcd-ask-history-variable (prompt)
"Generate history variable for PROMPT."
(let ((description (format "History for `%s' prompt." prompt)))
(rcd-symbol-if-not-exist (concat "rcd-" prompt "-history") nil description)))
(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 (not text))
(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)
"Return string from list of strings"
(mapconcat 'identity list ""))
(defun list-has (needle haystack)
"Return 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-elements (needles haystack)
"Return elements of haystack that contain needle, case insensitive"
(let ((elements))
(while needles
(let* ((needle (pop needles))
(haystack (list-has needle haystack)))
(mapc (lambda (item) (push item elements)) haystack)))
(reverse elements)))
(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)
(defun rcd-hash-ensure (hash)
"Ensure HASH to be hash with :TEST #\\='equal."
(cond ((hash-table-p hash) hash)
(t (make-hash-table :test #'equal))))
;;;; VECTOR FUNCTIONS
(defun vector-to-list (vector)
"Return list from VECTOR."
(append vector '()))
;;;; NUMBER FUNCTIONS
(defun random-number (&optional digits)
"Return 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)))))))
(defun clisp-number-to-words (n &optional trim)
"Return 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))
(defvar rcd-digits-to-words
'((1 . "ONE") (2 . "TWO") (3 . "THREE") (4 . "FOUR") (5 . "FIVE")
(6 . "SIX") (7 . "SEVEN") (8 . "EIGHT") (9 . "NINE") (0 . "ZERO"))
"Return `alist' for digits to words functions.")
(defun rcd-superscript-digit-1 (number)
"Return unicode digit by name SUPERSCRIPT DIGIT NUMBER."
(char-to-string
(char-from-name (concat "SUPERSCRIPT DIGIT " (cdr (assoc number rcd-digits-to-words))))))
(defun rcd-superscript-digits (number)
"Return unicode digits for NUMBER."
(let* ((string (cond ((numberp number) (number-to-string number))
((stringp number) number)))
(digits (split-string string "" t " ")))
(with-temp-buffer
(while digits
(insert (rcd-superscript-digit-1 (string-to-number (pop digits)))))
(buffer-string))))
;;;; SQL FUNCTIONS
(defun sql-number-or-null (number)
(cond ((numberp number) number)
((null number) "NULL")))
(defun sql-escape-string-or-null (s)
(cond ((and (stringp s) (length> s 0)) (sql-escape-string s))
(t "NULL")))
(defun sql-escape-string (str &optional trim)
"Return sql escaped string for PostgreSQL. If STR is NIl return `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)
"Return 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-current-weekday ()
"Return the current day of week."
(rcd-sql-first "SELECT EXTRACT(DOW FROM now())::integer" cf-db))
(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-string-numbers-sum (string)
"Returns the numerical sum of all numbers within a string.
For example \"2 4 12\" would result with 18."
(apply #'+ (string-to-list string)))
(defun rcd-sql-true-or-null (any)
"Return ANY or 'NULL'."
(cond (any any)
(t "NULL")))
(defun rcd-sql-id-list (list)
"Return comma concatenated LIST of numbers as string."
(mapconcat #'number-to-string list ", "))
(defun rcd-comma-list (list)
"Return comma concatenated LIST of any type of items"
(mapconcat (lambda (item) (format "%s" item)) list ", "))
;;;; BUFFER FUNCTIONS
(defun rcd-propertize-bold (s)
"Return bold string S."
(put-text-property 0 (length s) 'face 'bold s)
s)
(defun rcd-highlight-list (list)
"Highlight LIST of regular expressions 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)))
(when (and (> left 0) (> right 0))
(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-list-of-strings-for-any-types (list)
"Return list of strings for LIST of any types."
(mapcar (lambda (item) (if (stringp item) item (prin1-to-string item))) list))
(defun rcd-ask-without-list (without-list &optional prompt initial-input default-value auto-initial-input)
"Do same as `rcd-ask' while excluding WITHOUT-LIST."
(let ((output)
(without-list (rcd-list-of-strings-for-any-types without-list)))
(while (list-has-elements
without-list
(split-string
(setq output (rcd-ask prompt initial-input default-value auto-initial-input)))))
output))
(defun read-from-buffer (&optional value buffer-name mode title keymap place highlight-list minor-modes input-method)
"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))
(while minor-modes
(let ((minor-mode (pop minor-modes)))
(if minor-mode
(if (fboundp (intern minor-mode))
(funcall (intern minor-mode))
(rcd-message "You need `%s' minor mode" (symbol-name minor-mode))))))
(setq rcd-db-current-table table)
(setq rcd-db-current-column column)
(setq rcd-db-current-table-id table-id)
;; (local-set-key (kbd "C-c C-c") 'exit-recursive-edit)
(local-set-key (kbd "<f8>") 'exit-recursive-edit)
(when keymap
(use-local-map keymap))
(when input-method (set-input-method input-method))
(when rcd-word-processing
(rcd-word-processing))
(setq header-line-format (format "%s ➜ Finish editing with or C-M-c or F8" title))
(if (stringp value) (insert value))
(rcd-highlight-list highlight-list)
(goto-char (or point (point-min)))
(rcd-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 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 rcd-speak-festival (string)
"Return speech by using festival if the `rcd-speech' variables
is true and `festival-program-name' has some value"
(unless (fboundp 'festival-program-name)
(require 'festival nil t))
(if (and rcd-speech (fboundp '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))
(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 (rcd-ask prompt)))
(insert open)
(insert word)
(insert close))))
(defun rcd-markdown-tag (type)
(cond ((eq 'strong type) '("*" "*"))
((eq 'italic type) '("_" "_")))) ;; TODO
(defun rcd-html-tags (type)
(cond ((eq 'strong type) '("<strong>" "</strong>"))
((eq 'italic type) '("<em>" "</em"))))
(defun rcd-markup-tags-by-mode ()
(cond ((eq 'markdown-mode major-mode) 'rcd-markdown-tag)
((eq 'adoc-mode major-mode) 'rcd-asciidoc-tag)
((eq 'html-mode major-mode) 'rcd-html-tags)))
(defun rcd-bracket-region-heavy-angle-bracket-ornaments ()
(interactive)
(rcd-enclose-region-ask "❰" "❱"))
(defun rcd-html-tag (&optional tag)
(interactive)
(let* ((tag (or tag (rcd-ask "HTML Tag: " nil nil t)))
(open (format "<%s>" tag))
(close (format "</%s>" tag)))
(rcd-enclose-region-ask open close)))
(defun rcd-markup-tag ()
(interactive)
(let* ((tag (rcd-ask "Markup Tag: " nil nil t)))
(rcd-enclose-region-ask tag tag)))
(defun rcd-markup-asciidoctor-tel ()
"Replace region assuming it is phone number to `tel:' link."
(interactive)
(let* ((region (rcd-region-string))
(phone (replace-regexp-in-string "-" "" region))
(tel (format "link:tel:%s[%s]" phone region)))
(rcd-region-string-replace tel)))
(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)
"Return 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)
"Return = as string for number of times"
(let ((count 0))
(while (<= count times)
(insert "=")
(setq count (1+ count)))))
;;;; REPEAT FUNCTIONS
(defun rcd-repeat-until-not-nil (function &rest args)
"Repeat FUNCTION with optional ARGS until result is not nil."
(let ((result))
(while (not (setq result (apply function args))))
result))
(defun rcd-repeat-until-not-empty-string (function &rest args)
"Repeat FUNCTION with optional ARGS until result is not empty string."
(let ((result))
(while (string-empty-p (setq result (apply function args))))
result))
(defun rcd-is-nothing-p (thing)
"Return TRUE if THING is nothing."
(cond ((and (stringp thing) (seq-empty-p thing)) t)
;; ((and (numberp thing) (not thing)) t)
((null thing) t)
(t nil)))
(defun rcd-is-something-p (thing)
"Return TRUE if THING is something."
(cond ((and (stringp thing) (seq-empty-p thing)) nil)
;; ((and (numberp thing) (not thing)) nil)
((null thing) nil)
(t t)))
(defun rcd-repeat-until-something (function &rest args)
"Repeat FUNCTION with optional ARGS until result is something.
Result shall be non empty string or number."
(let ((result))
(while (rcd-is-nothing-p (setq result (apply function args))))
result))
;;;; MISCELLANEOUS FUNCTIONS
(defun rcd-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 ()
"Return the last pressed key"
(let ((keys (recent-keys)))
(car (append (reverse keys) '()))))
(defun last-key-binding ()
"Return the last pressed key"
(key-binding (vector last-input-event) t))
;; ⟦ (last-key-binding) ⟧
;;;; LISP DATA FUNCTIONS
(defun string-to-file-force (string file)
"Prints string into file, matters not if file exists. Return 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"
(condition-case nil
(car (read-from-string
(file-to-string file)))
(error nil)))
(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)))))
;;; Check Functions
(defun rcd-check (&optional check-in check-out)
"Replace matches of CHECK-IN with CHECK-OUT in a line.
It is useful to toggle [ ] to [✔]"
(interactive)
(let* ((start (line-beginning-position))
(end (line-end-position))
(check-in (or check-in "❰ ❱"))
(check-out (or check-out "❰DONE❱")))
(rcd-check-start check-in check-out)
(save-excursion
(goto-char start)
(cond ((search-forward-regexp (regexp-quote check-in) end t)
(replace-match check-out))
((search-forward-regexp (regexp-quote check-out) end t)
(replace-match check-in))))))
(defun rcd-check-start (&optional check-in check-out)
"Insert variable `check-in' at the beginning of line."
(interactive)
(let* ((start (line-beginning-position))
(end (line-end-position))
(line (buffer-substring start end))
(check-in (or check-in "❰ ❱"))
(check-out (or check-out "❰DONE❱")))
(when (not (string-match (regexp-opt (list check-in check-out)) line))
(save-excursion
(goto-char start)
(insert check-in " "))
(when (= start end)
(goto-char (line-end-position))))))
;;;; FILE FUNCTIONS
(defun rcd-checksum-b2sum (file)
"Verify checksum by using `b2sum' command."
(let ((executable (executable-find "b2sum")))
(cond (executable (car (split-string (call-process-to-string executable file nil "-b"))))
(t (error "Cannot find `b2sum'")))))
(defun rcd-count-files-in-directory (dir)
"Return number of files in DIR directory."
(length (directory-files dir nil "[[:alnum:]]" t)))
(defun three-parent-dirs (path)
"Return 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 ()
"Normalize files marked in Dired."
(interactive)
(if (dired-get-marked-files)
(let ((all-files (dired-get-marked-files)))
(while all-files
(let ((single-file (pop all-files)))
(if (file-directory-p single-file)
(let ((files (directory-files-recursively single-file "")))
(while files
(let ((file (pop files)))
(rcd-normalize-file file)))
(rcd-normalize-file single-file))
(rcd-normalize-file single-file))))
(revert-buffer))
(rcd-warning-message "Works only in Dired")))
(defun rcd-normalize-file (file)
"Chmod 755 a directory or 644 any file."
(cond ((file-directory-p file) (chmod file 493))
(t (chmod file 420))))
(defun parent-dir (path)
"Return 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* ((resize-mini-windows t) ;; TODO maybe not needed, rather setting max-mini-window-height?
(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 rcd-spit-stars (n)
"Return N stars"
(make-string n 42))
(defun rcd-report-underlined (name text &optional no-upcase)
"Return report with underlined heading NAME and TEXT."
(cond ((stringp text) (with-temp-buffer
(insert (underline-text (cond (no-upcase name)
(t (upcase name))))
text "\n\n")
(buffer-string)))
(t "")))
(defun heading-underlined ()
"Asks for title and underlines it."
(interactive)
(let* ((heading (rcd-ask-get "Heading:"))
(heading (upcase heading))
(l (length heading)))
(insert heading)
(insert ":\n")
(insert-= l)
(insert "\n")))
(defun underline-text (text &optional no-newlines char)
"Asks for TEXT and returns it underlined. If optional
NEW-NEWLINES is true, it will not add new lines."
(let* ((l (length text))
(char (or char "="))
(newlines (if no-newlines "" "\n\n")))
(format "%s\n%s%s" text
(with-output-to-string
(let ((count 0))
(while (< count l)
(princ char)
(setq count (1+ count)))))
newlines)))
(defun underline-text-interactive (text)
"Underlines and insert text into buffer"
(interactive "sText: ")
(insert (underline-text text)))
(defun underline-line (&optional prefix)
"Underline the current line."
(interactive "p")
(message "%s" prefix)
(let* ((start (line-beginning-position))
(end (line-end-position))
(length (string-width (buffer-substring-no-properties start end)))
(char (if prefix
(cond ((eq prefix 4) ?=)
((eq prefix 16) ?━)
((eq prefix (expt 4 3)) ?═)
((eq prefix (expt 4 4)) ?╍)
(t ?-))
?-)))
(end-of-line)
(newline)
(insert (make-string length char))
(newline)))
;;;; EXTERNAL PROGRAMS
(defun pdfinfo (file)
"Return 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 (rcd-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 &optional prefer-mime)
"Return 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 (and (not prefer-mime) 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 rcd-go-home ()
"Go to home directory $HOME"
(cd (getenv "HOME")))
(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) 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* ((out (apply 'rcd-command-output-from-input "psql" sql "-q" "-f" "-" args)))
out))
(defun psql-table-definition (table &optional map)
(let ((argument (format "\\d %s" table)))
(rcd-pop-to-report
(call-process-to-string "psql" nil nil
"-P" "border=2"
"-P" "linestyle=unicode"
"-c" argument)
nil map nil nil t)))
(defun psql-html (sql &rest args)
(let* ((sql (rcd-string-clean-whitespace sql))
(out (apply 'rcd-command-output-from-input "psql" sql "-AHS" "-f" "-" args)))
out))
(defun psql-asciidoc (sql &rest args)
(apply 'rcd-command-output-from-input "psql" sql "-P" "format=asciidoc" "-f" "-" args))
(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 ()
"Return string from region without properties."
(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) ""))
(defvar rcd-markdown-arguments nil)
;; '("--enable-alpha-list"))
(defun rcd-markdown (text &rest args)
"Markdown processing"
(if text (apply 'rcd-command-output-from-input "markdown" (append (list text) args)) ""))
(defun rcd-org-to-markdown-to-html (text &rest args)
"Convert Org TEXT to markdown."
(apply 'rcd-markdown
(append (list (with-temp-buffer
(insert text)
(org-export-to-buffer 'md (current-buffer) nil nil nil t)
(buffer-string)))
args)))
(defun rcd-pandoc-list-input-formats ()
"Return Pandoc input formats as Lisp list."
(let* ((list (string-trim (shell-command-to-string "pandoc --list-input-formats")))
(list (split-string list "\n")))
list))
;; (rcd-pandoc-list-input-formats) ⇒ ("biblatex" "bibtex" "commonmark" "commonmark_x" "creole" "csljson" "csv" "docbook" "docx" "dokuwiki" "epub" "fb2" "gfm" "haddock" "html" "ipynb" "jats" "jira" "json" "latex" "man" "markdown" "markdown_github" "markdown_mmd" "markdown_phpextra" "markdown_strict" "mediawiki" "muse" "native" "odt" "opml" "org" "rst" "rtf" "t2t" "textile" "tikiwiki" "twiki" "vimwiki")
(defun rcd-pandoc-list-output-formats ()
"Return Pandoc output formats as Lisp list."
(let* ((list (string-trim (shell-command-to-string "pandoc --list-output-formats")))
(list (split-string list "\n")))
list))
;, (rcd-pandoc-list-output-formats) ⇒ ("asciidoc" "asciidoctor" "beamer" "biblatex" "bibtex" "commonmark" "commonmark_x" "context" "csljson" "docbook" "docbook4" "docbook5" "docx" "dokuwiki" "dzslides" "epub" "epub2" "epub3" "fb2" "gfm" "haddock" "html" "html4" "html5" "icml" "ipynb" "jats" "jats_archiving" "jats_articleauthoring" "jats_publishing" "jira" "json" "latex" "man" "markdown" "markdown_github" "markdown_mmd" "markdown_phpextra" "markdown_strict" "markua" "mediawiki" "ms" "muse" "native" "odt" "opendocument" "opml" "org" "pdf" "plain" "pptx" "revealjs" "rst" "rtf" "s5" "slideous" "slidy" "tei" "texinfo" "textile" "xwiki" "zimwiki")
(defun rcd-pandoc-convert-string (string input-format output-format &rest args)
"Return STRING converted by Pandoc from INPUT-FORMAT to OUTPUT-FORMAT."
(if (rcd-which-list '("pandoc"))
(let ((input-exists (member input-format (rcd-pandoc-list-input-formats)))
(output-exists (member output-format (rcd-pandoc-list-output-formats))))
(if (and input-exists output-exists)
(apply 'rcd-command-output-from-input "pandoc" string "-f" input-format "-t" output-format args)
(rcd-warning-message "Either input format `%s' or output format `%s' does not exist" input-format output-format)))
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(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 &optional reference-location)
"Return plain text from Markdown by using pandoc
REFERENCE-LOCATION may be block, section or document"
(if (rcd-which-list '("pandoc"))
(let* ((reference-location (or reference-location "block"))
(reference-location (format "--reference-location=%s" reference-location)))
(rcd-command-output-from-input "pandoc" string reference-location "--reference-links" "-f" "markdown" "-t" "plain"))
(rcd-warning-message "RCD ERROR: Could not find `pandoc' in $PATH")))
(defun rcd-pandoc-html-to-plain (string)
"Return 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)
"Return HTML from txt2tags"
(if text
(rcd-command-output-from-input "txt2tags" (concat "\n" text) "--no-style" "--toc" "-H" "-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-elinks-html-to-plain (string)
"Return plain text from HTML by using `elinks'."
(command-stream-in-out "elinks" string "-force-html" "-dump"))
(defun rcd-asciidoctor-to-text (asciidoc &rest args)
"Return plain text for ASCIIDOC string."
(let* ((html (apply 'rcd-asciidoctor asciidoc args))
(text (rcd-command-output-from-input "lynx" html "-dump" "-stdin")))
text))
(defun rcd-asciidoctor (string &rest args)
"Return plain text from Markdown by using pandoc"
(rcd-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-asciidoc-markup-image-string (image &optional width align title)
(let* ((width (or width 450))
(align (or align "center"))
(title (if title (concat "." title "\n")))
(image (format "%simage::%s[width=%s,align=%s]\n" title image width align)))
image))
(defun rcd-asciidoc-markup-image-strings (s)
(let* ((split (split-string s " " t))
(joined (mapconcat 'rcd-asciidoc-markup-image-string split " ")))
joined))
;;;; HTML text menu system
(defun rcd-html-text-menu-link (name link &optional separator)
"Return HTML link for NAME and LINK with optional SEPARATOR."
(format " <a href=\"%s\" title=\"%s\">%s</a> %s" link name name (or separator "★")))
(defun rcd-html-text-menu-start (&optional separator menu-name)
"Return the start of the HTML text menu."
(format "<strong>⮞⮞⮞ %s: %s%s%s </strong>"
(or menu-name "MENU") (or separator "★") (or separator "★") (or separator "★")))
(defun rcd-html-text-menu-end (&optional separator)
"Return the end of the HTML text menu."
(format "<strong>%s%s ⮜⮜⮜</strong>" (or separator "★") (or separator "★")))
(defun rcd-html-text-menu-list (list &optional separator)
"Return HTML text menu for LIST of links.
List shall consists of lists with name and link per entry."
;; Consider different options for different markups
(with-temp-buffer
(while list
(let* ((entry (pop list))
(name (pop entry))
(link (pop entry)))
(insert (rcd-html-text-menu-link name link separator))))
(buffer-string)))
(defun rcd-html-text-menu (list &optional separator menu-name)
"Return HTML text menu for LIST.
SEPARATOR is optional."
(concat (rcd-html-text-menu-start separator menu-name)
(rcd-html-text-menu-list list separator)
(rcd-html-text-menu-end separator)))
;;; Button functions
(defun rcd-button-insert (button-text action-function &optional how-many revert-key revert-value)
"Insert button BUTTON-TEXT with ACTION-FUNCTION.
Optional number HOW-MANY adds superscript digits to BUTTON-TEXT."
(let* ((revert-key (or revert-key "revert-key"))
(revert-key (intern revert-key))
(revert-value (or revert-value button-text)))
(insert-text-button button-text
'action
action-function
'follow-link t
revert-key revert-value)
(when how-many
(insert (rcd-superscript-digits how-many)))))
(defun rcd-button-revert-source (&optional revert-key)
"Revert the button source.
REVERT-KEY is optional and by default the symbol 'REVERT-KEY. The
value of REVERT-KEY will be returned as source."
;; (rcd-button-insert "Hello" (lambda (_) (message-box "Hello")) nil nil "⟦ (hyperscope 123) ⟧")
(let ((point (point))
(revert-key (or revert-key 'revert-key)))
(save-excursion
(goto-char (point-min))
(let (my-prop)
(while (setq my-prop
(text-property-search-forward
revert-key))
(when my-prop
(let ((begin (prop-match-beginning my-prop))
(end (prop-match-end my-prop))
(value (prop-match-value my-prop)))
(set-text-properties (1- begin) end nil)
(delete-region begin end)
(goto-char begin)
(insert (format "%s" value)))))))
(goto-char point)))
;;; E-mail functions
(defun rcd-write-email (from-name from-email &optional to-name to-email signature subject)
"Write email FROM-NAME FROM-EMAIL.
Optionally include TO-NAME TO-EMAIL."
(let ((user-full-name from-name)
(user-mail-address from-email)
(mail-signature (or signature ""))
(to (cond ((and to-name to-email) (concat to-name " <" to-email ">"))
(t nil))))
(mail nil to nil)
(mail-subject)
(when subject (insert subject))))
;;;; Markup
(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 'html-mode) (rcd-markdown-preview))
((eq major-mode 'mhtml-mode) (rcd-markdown-preview))
((eq major-mode 't2t-mode) (rcd-txt2tags-html-preview))
((eq major-mode 'text-mode) (rcd-template-buffer-preview))
((eq major-mode 'mail-mode) (rcd-template-buffer-preview))
((eq major-mode 'org-mode) (rcd-org-html-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-asciidoctor-to-pdf (asciidoc file &rest args)
"Process string ASCIIDOC with `asciidoctor-pdf' with output to FILE."
(apply 'rcd-command-output-from-input "/home/data1/protected/.gem/ruby/3.0.0/bin/asciidoctor-pdf" asciidoc "-o" file "-" args))
(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-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-org-html-preview ()
"Preview Org HTML"
(interactive)
(let* ((buffer (buffer-string))
(output (if (fboundp 'rcd-template-eval)
(if current-prefix-arg
(with-temp-buffer
(org-mode)
(insert (rcd-template-eval buffer))
(buffer-string))
buffer)
buffer))
(output (with-temp-buffer
(insert output)
(org-export-to-buffer 'html (current-buffer) nil nil nil t)
(buffer-string)))
(file (string-to-file-force output (concat (or (getenv "TMPDIR") "/tmp/") "org-preview.html"))))
(browse-url file)))
(defun rcd-html-simple-note (title text)
(format "<html>\n\t<head>\n\t\t<title>%s</title>\n\t</head>\n\n\t<body>\n\t\t<p>%s</p>\n\t</body>\n</html>" title text))
(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 meta-tags)
"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\">")
(meta-tags (or meta-tags (wrs-standard-meta-tags title)))
(text (concat header "\n" text)))
(rcd-command-output-from-input "mkd2html" text "-header" viewport-line "-header" meta-tags "-header" css-line)))
(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 rcd-primary-selection ()
;; "Return X primary selection"
;; (let ((primary ()(gui-get-selection 'PRIMARY 'STRING)))
;; (shell-command-to-string "xclip -selection primary -out")
;; (rcd-warning-message "RCD ERROR: `xclip' not found in $PATH")))
(defun xclip-primary-selection-html-exist ()
(when (string-match "text/html" (call-process-to-string "xclip" nil nil "-t" "TARGETS" "-selection" "primary" "-out")))
t)
(defun xclip-primary-selection-html ()
"Return text/html X primary selection"
(if (rcd-which-list '("xclip"))
(if (xclip-primary-selection-html-exist)
(progn
(message "Trying to get primary selection, abort process if too long")
(call-process-to-string "xclip" nil nil "-t" "text/html" "-selection" "-primary" "-out"))
(rcd-warning-message "xclip did not get text/html target"))
(rcd-warning-message "RCD ERROR: `xclip' not found in $PATH")))
;;;; REMOTE SERVER TOOLS: SSH, SCP, RSYNC
(defun rcd-scp (full-path username server remote-path &rest args)
"Use shell command `scp' to transfer FULL-PATH to remote SERVER.
USERNAME and REMOTE-PATH shall be specified.
Optional ARGS may be used to supply any other `scp' argument."
(if (rcd-which-list '("scp"))
(let* ((full-path (file-truename full-path))
(scp-path (concat username "@" server ":" remote-path))
(args (flatten-list (list args full-path scp-path))))
(message "Using `scp' to transfer `%s' to `%s'" (file-name-nondirectory full-path) scp-path)
(apply 'call-process "scp" nil "*RCD scp*" nil args))
(rcd-warning-message "RCD ERROR: `scp' not found in $PATH")))
(defun rcd-ssh-mkdir (username server remote-path &rest args)
"Use shell command `ssh' to make sure REMOTE-PATH exists on SERVER.
USERNAME shall be specified.
Optional ARGS may be used to supply any other `ssh' argument."
(if (rcd-which-list '("ssh"))
(let* ((ssh-server (concat username "@" server))
(directory (file-name-directory remote-path))
(args (flatten-list (list args "mkdir" "-p" directory))))
(message "Using `ssh' to make directory `%s:%s'" ssh-server directory)
(apply 'call-process "ssh" nil "*RCD ssh*" nil ssh-server args))
(rcd-warning-message "RCD ERROR: `ssh' not found in $PATH")))
(defun rcd-rsync (full-path username server remote-path &rest args)
"Use shell command `rsync' to transfer FULL-PATH to remote SERVER.
USERNAME and REMOTE-PATH shall be specified.
Optional ARGS may be used to supply any other `rsync' argument."
(if (rcd-which-list '("rsync"))
(let* ((rsync-path (concat username "@" server ":" remote-path))
(args (flatten-list (list args full-path rsync-path))))
(message "Using `rsync' to transfer `%s' to `%s'" (file-name-nondirectory full-path) rsync-path)
(apply 'call-process "rsync" nil "*RCD rsync*" nil args))
(rcd-warning-message "RCD ERROR: `rsync' not found in $PATH")))
(defun rcd-rsync-mkdir (full-path username server remote-path &rest args)
"Use shell command `rsync' to transfer FULL-PATH to remote SERVER.
Makes sure that REMOTE-PATH exists.
USERNAME and REMOTE-PATH shall be specified.
Optional ARGS may be used to supply any other `rsync' argument."
(if (rcd-which-list '("rsync"))
(let* ((rsync-path (concat username "@" server ":" remote-path))
(remote-directory (file-name-directory remote-path))
(mkdir (concat "mkdir -p '" remote-directory "' && rsync"))
(args (flatten-list (list args "--rsync-path" mkdir full-path rsync-path))))
(message "Using `rsync' to transfer `%s' to `%s'" (file-name-nondirectory full-path) rsync-path)
(apply 'call-process "rsync" nil "*RCD rsync*" nil args))
(rcd-warning-message "RCD ERROR: `rsync' not found in $PATH")))
;;;; MATHEMATICAL FUNCTIONS
(defun rcd-volume-m3-by-mm (width-mm height-mm length-mm)
"Return volume in cubic meters for WIDTH-MM, HEIGHT-MM, LENGTH-MM."
(/ (* (float width-mm) height-mm length-mm) 1000000000.0))
(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 (&rest 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)))
(defun pct-100-for (number percentage)
"Return 100% percent for NUMBER being PERCENTAGE.
PERCENTAGE shall be expressed from 1 to 100."
(let ((one-percent (/ number (float percentage))))
(* 100 one-percent)))
;;;; ENVIRONMENT
(defun rcd-memory-dir ()
(let ((xdg-runtime-dir (getenv "XDG_RUNTIME_DIR")))
(if xdg-runtime-dir (file-name-as-directory xdg-runtime-dir)
(if (and (file-directory-p "/dev/shm")
(file-writable-p "/dev/shm"))
(file-name-as-directory "/dev/shm")))))
;;;; MEMORY FUNCTIONS
(defun kill-any (any)
(kill-new (format "%s" any))
(message "Killed: %s" any))
;;;; PROGRAMMING TOOLS
(defun rcd-symbol-if-not-exist (variable &optional value description)
"Return symbol for VARIABLE string.
It will generate new VARIABLE if it does not exist."
(let* ((variable (replace-regexp-in-string "[^[:alnum:]]" "-" (downcase variable)))
(rcd-symbol (intern variable))
(description (or description (format "Generated variable `%s'" variable))))
(if (boundp rcd-symbol)
rcd-symbol
(eval (list 'defvar rcd-symbol value description)))))
(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-system-date (locale &optional date-format)
"Return date as given by system command `date' by using LOCALE."
(let ((date-format (or date-format "+%A, %x %X")))
(string-trim
(call-process-to-string "env" nil nil (format "LC_ALL=%s" locale) "date" date-format))))
(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-email ()
"Return timestamp suitable for email."
(format-time-string "%a, %e %B %Y %T %z" nil 'wall))
(defun rcd-timestamp-date-time ()
"Return 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)
"Return 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 ()
"Return 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 (&optional prefix)
"Insert date in ISO format."
(interactive "p")
(cond ((eq prefix 4) (progn
(insert (format-time-string "%m/%d/%Y"))
(message "Inserted date in US format")))
((eq prefix 16) (progn
(insert (format-time-string "%c"))
(message "Inserted date/time in locale's date and time format")))
((eq prefix 64) (progn
(insert (format-time-string "Last updated: %c"))
(message "Inserted date/time last update stamp")))
(t (progn
(insert (format-time-string "%Y-%m-%d"))
(message "Inserted date in ISO format")))))
(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-read-iso-date ()
(let* ((date (calendar-read-date))
(month (elt date 0))
(day (elt date 1))
(year (elt date 2)))
(format "%04d-%02d-%02d" year month day)))
(defun rcd-date-dir (&optional ask-for-date)
"Return 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)
"Return 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"))
((string-match ".svg$" image) '("inkscape" "")) ;; Why this empty argument?
(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 (rx line-start (or "jpg" "jpeg" "heic" "png") line-end) (downcase extension))
(message "Optimizing `%s'" file)
(call-process "mogrify" nil "-sampling-factor" "4:2:0" "-strip" "-interlace" "JPEG" "-colorspace" "sRGB" "-format" extension "-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) "heic")
(equal (downcase extension) "png"))
(let* ((file (shell-double-quote file))
(command (format "mogrify -colorspace sRGB -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)
"Display RCD messages.
Variable `rcd-message-buffer' holds the name of buffer."
(let ((current (current-buffer))
(format-string (concat (rcd-timestamp) " " format-string)))
(when rcd-message-active
(get-buffer-create rcd-message-buffer)
(set-buffer rcd-message-buffer)
(goto-char (point-max))
(insert
(apply 'format format-string message)
"\n")
(goto-char (point-max))
(set-buffer current))
(apply 'message format-string message)))
;;;; SOUND AND AUDIO FUNCTIONS
(defun rcd-espeak-word ()
"Speak word at point."
(interactive)
(let ((word (thing-at-point 'word t)))
(when word
(rcd-espeak word))))
(defun rcd-espeak-region ()
"Speak region"
(interactive)
(when (region-active-p)
(rcd-espeak (rcd-region-string))))
(defun rcd-speak (text)
"Returnes speech for TEXT by using RCD-SPEAK-FUNCTION."
(when rcd-speech)
(rcd-message "%s" text)
(funcall rcd-speech-function text))
(defun rcd-speak-toggle ()
"Toggles the speech output"
(interactive)
(cond (rcd-speech (setq rcd-speech nil))
(t (setq rcd-speech t)))
(rcd-message (format "Variable `rcd-speech': %s" rcd-speech)))
(defun rcd-espeak (&optional text speed)
"Speaks text by espeak"
(interactive)
(when (rcd-which "espeak")
(when rcd-speech
(let* ((amplitude rcd-espeak-amplitude)
(voice rcd-espeak-voice)
(speed (or speed 175))
(text (or text (rcd-ask "Speak text: ")))
(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 map place refresh truncate return-function)
"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))
(set-buffer (get-buffer buffer))
(read-only-mode 0)
(erase-buffer))
(save-excursion
(pop-to-buffer buffer)
(let ((word-wrap truncate))
(when word-wrap (toggle-truncate-lines 1))
(setq rcd-db-current-table (when (listp place) (cdr (assoc "table" place))))
(setq rcd-db-current-column (when (listp place) (cdr (assoc "column" place))))
(setq rcd-db-current-table-id (when (listp place) (cdr (assoc "table-id" place))))
(setq rcd-tabulated-refresh-function refresh)
(setq rcd-current-return-function return-function)
(insert string)
(goto-char 1)
(cond (map (use-local-map map))
(t (local-set-key (kbd "q") 'kill-buffer-and-window)))
(read-only-mode 1)))))
;;; RCD Notes
(defun rcd-notes-kill-buffers ()
"Kill matching RCD Notes buffers."
(interactive)
(kill-matching-buffers (concat "^" rcd-program-name) t t))
;;;; TABULATED MODE FUNCTIONS
(defmacro when-tabulated-id (table &rest body)
"Run BODY only in current buffer with TABLE."
(declare (indent 2) (debug t))
;;(ignore id)
(rcd-go-home)
`(if id
(progn
,@body)
(if (or (equal ,table 'any)
(string-equal ,table rcd-db-current-table))
(let ((id (tabulated-list-get-id)))
(if id
(progn ,@body)
(rcd-message "Did not get ID")))
(rcd-message "This function is for table `%s' only" ,table))))
(defun rcd-uuid-p (uuid)
"Return TRUE if UUID is correct."
(and (stringp uuid) (string-match thing-at-point-uuid-regexp uuid)))
(defun rcd-kill-new (kill)
"Kill KILL."
(cond ((stringp kill) (progn
(kill-new kill)
(rcd-message "Killed: %s" kill)))
(t (rcd-message "😧 WARNING: Nothing to kill."))))
(defun rcd-tabulated-kill-id ()
"Kill (tabulated-list-get-id)"
(interactive)
(cond ((tabulated-list-get-id) (rcd-kill-new (format "%s" (tabulated-list-get-id))))
(t nil)))
(defun rcd-tabulated-id-to-register (digit &optional id)
"Insert ID in register by DIGIT."
(interactive "NEnter digit key and press ENTER: ")
(when-tabulated-id 'any
(when (> digit 10)
(rcd-warning-message "You had to press a digit key"))
(when (and id digit (< digit 10))
(let ((register (string-to-char (number-to-string digit))))
(set-register register id)))))
(defvar rcd-dont-switch-windows nil)
(defun rcd-tabulated-refresh (&optional id)
"Refresh buffer for ID in `tabulated-list-mode'."
(interactive)
(let ((current-buffer (current-buffer))
(line (line-number-at-pos))
(rcd-dont-switch-windows t))
(when rcd-tabulated-refresh-function
(funcall rcd-tabulated-refresh-function)
(cond (id (re-search-forward (format "^[[:blank:]]*%s " id) nil t))
(t (progn (goto-char 1)
(forward-line (1- line)))))
(kill-buffer current-buffer))))
(defun rcd-tabulated-filter-reset ()
"Reset filter in `tabulated-list-mode'."
(interactive)
(when rcd-tabulated-original-entries
(setq tabulated-list-entries rcd-tabulated-original-entries))
(tabulated-list-print))
(defun rcd-tabulated-filter ()
"Filter tabulated list mode interactively."
(interactive)
(when (null rcd-tabulated-original-entries)
(setq rcd-tabulated-original-entries tabulated-list-entries))
(let ((filter (string-trim (rcd-ask "Filter: "))))
(when (not (seq-empty-p filter))
(rcd-tabulated-entries-filter-general filter))))
(defun rcd-tabulated-mark-id (&optional id)
"Mark tabulated list ID."
(interactive)
(when-tabulated-id 'any
(tabulated-list-put-tag "⇉" t)
(push id rcd-tabulated-marked-items)
(setq rcd-tabulated-marked-items (seq-uniq rcd-tabulated-marked-items))
(rcd-message "Marked ID %s (total marked %s)" id (length rcd-tabulated-marked-items))))
(defun rcd-pushnew (elt list)
"Simple version of `pushnew'."
(cond ((member elt list) list)
(t (push elt list))))
(defun rcd-tabulated-unmark-id (&optional id)
"Unmark tabulated list ID."
(interactive)
(when-tabulated-id 'any
(setq-local rcd-tabulated-marked-items (delete id rcd-tabulated-marked-items))
(forward-line)
(rcd-message "Unmarked ID %s (%s)" id rcd-tabulated-marked-items)))
(defun rcd-tabulated-remove-marks ()
"Remove marks from tabulated list mode."
(interactive)
(cond (rcd-tabulated-marked-items
(tabulated-list-clear-all-tags)
(setq rcd-tabulated-marked-items nil)
(rcd-message "All marked items nullified"))
(t (rcd-warning-message "No marked items found"))))
(defun rcd-tabulated-iterate-generic (id function name &rest args)
"Iterate FUNCTION over ID or `rcd-tabulated-marked-items'.
Apply ARGS when necessary."
(let ((prompt (format (cond ((> (length rcd-tabulated-marked-items) 1) "Do you want to %s marked items?")
(t "Do you want to %s the ID?"))
name)))
(when (y-or-n-p prompt)
(let ((list (or rcd-tabulated-marked-items (list id))))
(while list
(apply function (pop list) args))))))
(defun rcd-tabulated-number-as-string-predicate (A B)
"Predicate to sort numbers in columns of strings.
Use this function as the SORT element within the variable
`tabulated-list-format'."
(let ((vA (string-to-number (aref (cadr A) 0)))
(vB (string-to-number (aref (cadr B) 0))))
(< vA vB)))
;;;; 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)
(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 "
# Draw Pie Chart in R
# 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.
pie(x, labels=labels, 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))))
;; Check if addition of values is 1
;; (if (= (round (apply #'+ values)) 1)
(defun wrs-standard-meta-tags (title &optional keywords description image generator author type url site-name)
"Return standard, Schema.org and Open Graph meta tags."
(let* ((type (or type "article"))
(meta-tags (format "
<!-- Hyperscope Meta Tags -->
<!-- meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\"/ -->
<meta name=\"generator\" content=\"%s\"/>
<meta name=\"author\" content=\"%s\"/>
<meta name=\"keywords\" content=\"%s\"/>
<meta name=\"description\" content=\"%s\"/>
<!-- Standard Meta Tags -->
<!-- Schema.org -->
<meta itemprop=\"name\" content=\"%s\" />
<meta itemprop=\"description\" content=\"%s\" />
<meta itemprop=\"image\" content=\"%s\" />
<!-- Schema.org -->
<!-- Open Graph -->
<meta property=\"og:title\" content=\"%s\"/>
<meta property=\"og:type\" content=\"%s\"/>
<meta property=\"og:url\" content=\"%s\"/>
<meta property=\"og:image\" content=\"%s\"/>
<meta property=\"og:site_name\" content=\"%s\"/>
<meta property=\"og:description\" content=\"%s\"/>
<!-- Open Graph -->
<!-- Hyperscope Standard Meta Tags -->\n"
(string-blank-if-nil generator) (string-blank-if-nil author) (string-blank-if-nil keywords) (string-blank-if-nil description)
(string-blank-if-nil title) (string-blank-if-nil description) (string-blank-if-nil image)
(string-blank-if-nil title) type (string-blank-if-nil url) (string-blank-if-nil image) (string-blank-if-nil site-name) (string-blank-if-nil description))))
meta-tags))
;;;; MEDIA UTILITIES
(defun image-dimension (file)
"Return 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)
"Return 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 rcd-media-dimension (file &optional mime-type)
"Return 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 rcd-media-scale (width height new-width)
"Return 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)))
;;;; SYMLINKS
(defun rcd-dired-show-symlink-target (&optional file)
"Show target of a link."
(interactive)
(let ((file (or file (car (dired-get-marked-files)))))
(if (and file (file-symlink-p file))
(let* ((target (file-truename file))
(target-exists (file-exists-p target))
(directory (file-name-directory target)))
(if target-exists
(progn
(find-file directory)
(dired-jump nil target))
(rcd-warning-message "Target does not exist: %s" target)))
(rcd-warning-message "Not a symlink: %s" file))))
;;;; WINDOW FUNCTIONS
(defun rcd-quit-window-or-kill ()
"Quit window if there is window parent, otherwise kill.
With `current-prefix-arg' kill current buffer."
(interactive)
(cond (current-prefix-arg (kill-current-buffer))
((window-parent) (quit-window))
(t (kill-current-buffer))))
(defun rcd-db-table-delete-entry (table id db rcd-db-sql-function &optional no-confirm)
"Delets entry by its ID without cascading."
(let ((sql (format "DELETE FROM %s WHERE %s_id = %s" table table id)))
(cond (no-confirm (progn (funcall rcd-db-sql-function sql db)
id))
((yes-or-no-p (format "Delete ID %s in table `%s'? " id table))
(progn (funcall rcd-db-sql-function sql db)
id))
(t (progn
(rcd-message "Did not delete ID %s" id)
nil)))))
;;;; 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 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: t
;; End:Source of this page
It may be interesting to see how source of this page looks like.
Related pages
-
How to insert new line in Emacs editor? ⎯ Several few ways are explained here on how to insert a new line before the current line while editing text with Emacs editor.
-
GNU Emacs Package: voice2html.el ⎯ Voice2HTML generates voice mail and publishes it on remote WWW server. This package serves the purpose to provide voice mail that may be quickly published on remote WWW servers. Requirement for user is to have own web hosting and SSH access to it. Why it is useful? You may send voice mail or voice messages to people over SMS, they can just click on the link in the SMS by using their smart phone and listen to the message directly. You could even send voice mail URL by letter to people who will later browse it online. Insert the URL for voice mail into email or other chat applications which otherwise do not allow transfers of voice.
-
GNU Emacs package: rcd-org-export.el — use Org to export Org ⎯ The GNU Emacs package rcd-org-export.el is a non-blocking alternative to Org export dispatch function. It will not block user’s screen. One can inspect the buffer and any keys and commands. It allows speedy mouse usage to make export breeze.