GNU Emacs package: rcd-utilities.el

GNU Emacs package: rcd-utilities.el

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 embedded code, then install it with:

{M-x package-install-file RET rcd-utilities.el RET}

The embedded code follows:

;;; rcd-utilities.el --- RCD utilities for GNU Emacs Lisp

;; Copyright (C) 2016-2020 Jean Louis

;; Author: Jean Louis <>
;; Version: 1.31
;; Package-Requires: (ivy calendar)
;; Keywords: extensions
;; URL:

;; 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
;; 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 <>.

;;; Commentary:

;; These are the RCD utilities for GNU Emacs Lisp used in other RCD
;; packages.
;; String functions:
;; List functions:
;; SQL related functions:
;; Buffer tools functions:
;; Speech functions:
;; Text functions:
;; Various tools:
;; LISP data functions:
;; Underlining functions:
;; Externel programs
;; RCD is acronym for Reach, Connect, Deliver, my personal
;; principle and formula for Wealth.

;;; Change Log:

;;; Code:

(setq lexical-binding t)

(require 'calendar)
(require 'cl-lib)
(require 'dired)
(require 'subr-x)
(require 'ivy)

(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)

(defvar *image-default-resize-size* 1536)
(defvar *image-resize-sizes* '())

;;;; String functions

(defun string-cut-id (s)
  "Returns the ID number, integer, from beginning of a string,
whereby space must follow the ID number, without many checks."
  (let* ((until (string-match " " s)))
    (if until
    (string-to-number (substring s nil until))

(defun string-cut-id-with-part (s)
  "Returns the ID as number and first part of string in a string
  that contains space after the ID, otherwise nil"
  (let* ((space (string-match " " s)))
    (if space
    (let* ((id (substring s 0 space))
           (id (string-to-number id))
           (rest (substring s (1+ space))))
      (if id (list id rest) nil))

(defun string-cut-right-square-bracket-reference (s)
  "Returns the reference within square brackets on the end of S."
  (let* ((space (string-match " " (reverse s))))
    (if space
    (let* ((id (substring (reverse s) 0 space)))
      (if (and (string-match "\\[" id)
           (string-match "\\]" id))
          (replace-regexp-in-string "\\[\\\|\\]" "" (reverse id))

(defun slash-add-clean (string)
  "Returns / on the end of the string if there is none"
  (let* ((string (replace-regexp-in-string " *" "" string))
     (slash (string-match "/$" string)))
    (if slash string (concat string "/"))))

(defun slash-add (path)
  "Adds slash `/` quickly on the end of string"
  (let ((last (substring (reverse path) 0 1)))
    (if (string= last "/") path
      (concat path "/"))))

(defun slash-remove (string)
  "Removes / on the end of the string if there is some"
  (replace-regexp-in-string "/*$" "" string))

(defun string-add (string add)
  "Returns string 'add' on the end of the string if there is none"
  (let* ((string (replace-regexp-in-string " *" "" string))
     (added (string-match (format "%s$" add) string)))
    (if added string (concat string add))))

(defun downcase-even-nil (s)
  "Helps that downcase works even with nil strings, useful for comparison of SQL data"
  (if (null s) ""
    (downcase s)))

(defun shell-double-quote (s)
  "Double quotes for the string that shall be fed to shell command"
  (replace-regexp-in-string "\"" "\\\\\"" s))

(defun string-to-double-quotes (s)
  (format "\"%s\"" s))

(defun string-to-single-quotes (s)
  (format "'%s'" s))

(defun escape-$ (s)
  "Escapes $ in strings, usually to avoid shell expansion"
  (replace-regexp-in-string "\\$" "\$" s))

(defun rcd-string-not-empty-p (s)
  "Returns T if string is empty or NIL"
  (let ((s (if (null s) "" s)))
    (if (stringp s)
    (if (zerop (length s)) nil t))))

(defun string-blank-nil (s)
  "Returns blank string for nil values"
  (if (null s) "" s))

;;; Currency functions

(defun eur-format (amount)
  (format "€ %d" amount))

(defun usd-format (amount)
  (format "US $%.2f" amount))

;;; Writing functions

(defun rcd-kill-to-signature (arg)
  "Kill all text up to the signature that begins with -- ."
  (interactive "P")
      (let ((point (point)))
    (narrow-to-region point (point-max))
    (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 '()))
    (dolist (c chars (list-of-strings-to-string (reverse nlist)))
      (let ((char (char-to-string c)))
     (cond ((string= ">" char) "&gt;")
           ((string= "<" char) "&lt;")
           ((string= "\"" char) "&quot;")
           ((string= "'" char) "&#39;")
           ((string= "&" char) "&amp;")
               (t char))

(defun spaces-to-%20 (s)
  (replace-regexp-in-string " " "%20" s))

(defun public-html-rest (path)
  "Returns the string after public_html/ if there is anything or path"
  (let* ((query (concat "/" (slash-add-clean rcd-public-html-basedir)))
     (length-q (length query))
     (length-p (length path))
     (found (string-match query path)))
    (if (and found (> length-p (+ found length-q)))
    (let ((from (+ length-q found)))
      (concat "https://" (spaces-to-%20 (substring path from))))

;;; Time and date functions

(defun rcd-timestamp-date-time ()
  "Returns the date by format YYYY-MM-DD-HH:MM:SS"
  (let* ((time (decode-time))
         (year (nth 5 time))
         (month (nth 4 time))
         (day (nth 3 time))
         (hour (nth 2 time))
         (minute (nth 1 time))
         (second (nth 0 time)))
    (format "%04.f-%02.f-%02.f-%02.f:%02.f:%02.f" year month day hour minute second)))

;;; Template functions

;; Few functions could not be placed here due to collision with the CL-EMB
;; from Common Lisp that generates this page

;;;; List functions

(defun list-of-strings-to-string (list)
  "Returns string from list of strings"
  (mapconcat 'identity list ""))

(defun list-has (needle haystack)
  "Returns elements of haystack that contain needle, case insensitive"
  (let ((nlist))
    (dolist (element haystack (reverse nlist))
      (when (string-match needle element)
    (cl-pushnew element nlist)))))

;; (defun list-has (needle haystack)
;;   "Returns elements of haystack that contain needle, case insensitive

;; Improvement by on help-gnu-emacs mailing list
;; 2020-10-18 23:59. "
;;   (seq-filter (lambda (elt) (string-match-p needle elt)) haystack))

(defun list-has-elements (needles haystack)
  "Returns elements of haystack that contain needle, case insensitive"
  (if needles
      (let* ((needle (pop needles))
         (haystack (list-has needle haystack)))
    (list-has-elements needles haystack))

;; (defun list-has-elements (needles haystack)
;;   "Returns elements of haystack that contain needle, case insensitive

;;   Improvement by on help-gnu-emacs mailing list
;; 2020-10-18 23:59. "
;;   (seq-reduce
;;    (lambda (red-haystack needle) (list-has needle red-haystack))
;;    needles
;;    haystack))

;; (list-has-elements '("H" "ma") '("Emacs" "Funny" "Hole" "Whole"))

(defun file-to-list (file)
  "Return a list of lines of a file"
    (insert-file-contents file)
    (split-string (buffer-string) "\n" t)))

(defun list-to-file (list file)
  "Prints list into file"
    (dolist (line list)
      (insert (concat line "\n")))
    (write-region (point-min) (point-max) file)))

(defun list-append-first-to-first-cons (list)
    "Cons with FIRST-ELT . FIRST-ELT"
  (let ((new-list '())
    (times (length list)))
    (dotimes (nr times new-list)
      (let* ((item (elt list nr)))
    (push (cons item item) new-list)))))

(defun list-of-formats (format list)
  (let ((new '()))
    (dolist (item list (reverse new))
      (push (format format item) new))))

(defun list-joined-with-format-and-separator (format list separator)
  (let ((list-1 (list-of-formats format list)))
    (mapconcat 'identity list-1 separator)))

;;; Hash functions

(defun hash-to-plist (hash)
  "Converts hash to plist"
  (let ((keys (hash-table-keys hash))
    (plist '()))
    (dolist (key keys plist)
      (setq plist (plist-put plist key (gethash key hash))))))

(defun hash-to-alist (hash)
  "Converts hash to alist"
  (let ((keys (hash-table-keys hash))
    (alist '()))
    (dolist (key keys alist)
      (setf (alist-get key alist) (gethash key hash)))))

;;; Vector functions

(defun vector-to-list (vector)
  "Returns list from VECTOR."
  (append vector '()))

;;; Number functions

(defun random-number (&optional digits)
  "Returns the random number with 6 digits by default"
  (let ((digits (if digits digits 6)))
       (dotimes (ti digits)
     (princ (number-to-string (1+ (random 9)))))))))

;;;; Published 2020-10-13
(defun number-to-words-clisp (n)
  "Returns the cardinal English number representation, for example if N is 4, it would return \"four\""
  (let* ((command (format "clisp -q -norc -x '(format t \"~R\" %d)'" n))
     (lines (split-string (shell-command-to-string command) "\n")))
    (car lines)))

;;; SQL related functions

(defun sql-escape-string (str)
  "Returnes escaped string for PostgreSQL. If string is `NULL' returns `NULL'"
  (if (null str)
      (setq str "NULL")
    (when (or (string-match "\\\\" str)
              (string-match "'" str))
      (setq str (replace-regexp-in-string "\\\\" "\\\\\\\\" str))
      (setq str (replace-regexp-in-string "'" "''" str))))
  (unless (string= "NULL" str)
    (setq str (format "E'%s'" str)))

(defun psql-age (date)
  "Returns age from given DATE by using external command `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)))
    (insert date)))

(defun rcd-sql-prepare-text-query (query)
  (let* ((query (string-trim query))
     (query (if (and (string-match " " query)
             (not (string-match "&" query)))
            (string-replace " " " & " query))))

;;;; Buffer tools functions

(defun pop-buffer-highlight-elements (query list buffer)
  "Pops buffer, inserts lines from a list and highlights queried elements"
  (pop-to-buffer buffer)
    (local-set-key "q" 'quit-window)
    (dolist (line list)
      (insert line)
      (insert "\n"))
    (dolist (phrase query)
      (highlight-phrase phrase)))

(defun read-from-buffer (&optional value buffer-name mode title)
  "Edits string and returns it"
  (let ((this-buffer (buffer-name))
    (title (or title ""))
    (value (or value ""))
    (new-value value)
    (read-buffer (if buffer-name buffer-name "*edit-string*")))
      (switch-to-buffer read-buffer)
      (set-buffer read-buffer)
      (if mode (funcall mode)
      (setq header-line-format (format "%s ➜ Finish editing with C-c C-c or C-M-c" title))
      (local-set-key (kbd "C-c C-c") 'exit-recursive-edit)
      (if (stringp value) (insert value))
      (speak "You may quit the buffer with Control C Control C")
      (message "When you're done editing press C-c C-c or C-M-c to continue.")
      (setq eval-expression-debug-on-error nil)
    (if (get-buffer-window read-buffer)
          (setq new-value (buffer-substring (point-min) (point-max)))
          (kill-buffer read-buffer))))
      (setq eval-expression-debug-on-error t)
      (switch-to-buffer this-buffer)
      new-value))) ;; TODO if mode is used, maybe it should not return propertized string

;;;; Speech functions

;;; TODO make it defcustom, set some defaults
(defvar rcd-speech-function 'identity "The function that handles strings to be spoken")
(defvar rcd-speech t "If TRUE the RCD programs will enable speech")
(defvar rcd-festival-function 'festival-say-string "Which festival function to be called")
(setq rcd-speech-function 'rcd-speak-festival)

(defun speak (string)
  "Returnes speech by using RCD-SPEAK-FUNCTION"
  (funcall rcd-speech-function string))

(defun rcd-speak-festival (string)
  "Returns speech by using festival if the `rcd-speech' variables
is true and `festival-program-name' has some value"
  (if (and rcd-speech (bound-and-true-p festival-program-name))
      (funcall rcd-festival-function string)))

;;;; Text functions

(defun insert-= (times)
  "Returns = as string for number of times"
  (let ((count 0))
    (while (<= count times)
      (insert "=")
      (setq count (1+ count)))))

;;;; Various tools

(defun split-attribute-colon-value (item)
  (let* ((split (split-string item ":"))
     (attribute (car split))
     (attribute (string-trim attribute))
     (attribute (replace-regexp-in-string " " "-" attribute))
     (value (cadr split))
     (value (if value (string-trim value) nil)))
    (list attribute value)))

(defun last-key ()
  "Returns the last pressed key"
  (let ((keys (recent-keys)))
    (car (append (reverse keys) '()))))

;;;; LISP data functions 

(defun string-to-file-force (string file)
  "Prints string into file, matters not if file exists. Returns FILE as file name."
    (with-temp-file file
      (insert string))

(defun file-to-string (file)
  "File to string function"
    (insert-file-contents file)

(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"
    (file-to-string file))))

;;;; Underlining functions

(defun heading-underlined ()
  "Asks for title and underlines it"
  (let* ((heading (read-from-minibuffer "Heading:"))
     (heading (upcase heading))
     (l (length heading)))
    (insert heading)
    (insert ":\n")
    (insert-= l)
    (insert "\n")))

(defun underline-text (text &optional no-newlines)
  "Asks for TEXT and returns it underlined. If optional
NEW-NEWLINES is true, it will not add new lines."
  (let* ((l (length text))
     (newlines (if no-newlines "" "\n\n")))
    (format "%s\n%s%s" text
          (let ((count 0))
        (while (< count l)
          (princ "=")
          (setq count (1+ count)))))

(defun underline-text-interactive (text)
  "Underlines and insert text into buffer"
  (interactive "sText: ")
  (insert (underline-text text)))

;;;; External programs

(defun pdfinfo (file)
  "Returns a list containing `pdfinfo' information"
  (let* ((command (format "pdfinfo '%s'" file))
     (info (shell-command-to-string command))
     (list (split-string info "\n"))
     (nlist '()))
    (dolist (item list nlist)
      (let* ((result (split-attribute-colon-value item))
         (attribute (car result))
         (attribute (downcase attribute))
         (la (length attribute))
         (value (cadr result))
         (lv (length value)))
    (if (> la 0)
        (setq nlist (plist-put nlist (intern attribute) value)))))))

(defun rcd-mime-type (file)
  "Returns mime type of the file"
  (let ((file-command (executable-find "file"))
    (mimetype (executable-find "mimetype")))
    ;; TODO:
    ;; There is much work to do here to work on various systems for
    ;; example there may not be same output on BSD and GNU systems.
    ;; Additional problem is file quoting.
    ;; file and mimetype may give different results
    (if file-command
    (string-trim (shell-command-to-string (format "%s -b --mime-type '%s'" file-command file)))
      (if mimetype
      (string-trim (shell-command-to-string (format "%s -b '%s'" mimetype file)))))))

(defun command-stream (command string &rest args)
    (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))

(defun command-stream-in-out (command string &rest args)
  (let* ((uid (number-to-string (user-uid)))
     (memory-dir (rcd-memory-dir))
     (infile (concat memory-dir "command-input")))
    (string-to-file-force string infile)
      (apply 'call-process command infile (current-buffer) nil args)

;;(command-stream-in-out "/usr/bin/env" makemime "new1" nil "TO-NAME=\"Jean Louis\"" "TO-EMAIL=\"\"" "/usr/local/bin/sendmail" "-F" "Jean" "-f" "" "--" "")

;;; Mathematical functions

(defun pct-minus (amount percent)
  "Return AMOUNT decreased for PERCENT of it."
  (let* ((percent (* amount percent))
         (result (- amount percent)))

(defun pct-plus (amount percent)
  "Return AMOUNT increased for PERCENT of it."
  (let* ((percent (* amount percent))
         (result (+ amount percent)))

(defun pct-plus-times (amount percent times)
  "Return AMOUNT increased for PERCENT for number of TIMES."
  (dotimes (var times amount)
    (setq amount (pct-plus amount percent))))

(defun pct-of-number-in-total (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)))
(defun pct-list (list)
  "Return list that representes percentages of values in a given LIST."
  (let* ((total (apply '+ list))
         (percents '()))
    (dolist (item list)
      (push (pct-of-number-in-total item total) percents))
    (reverse percents)))

;;; Environment

(defun rcd-memory-dir ()
  (let ((xdg-runtime-dir (getenv "XDG_RUNTIME_DIR")))
    (if xdg-runtime-dir (slash-add xdg-runtime-dir)
      (if (and (file-directory-p "/dev/shm")
           (file-writable-p "/dev/shm"))
      (slash-add "/dev/shm")))))

;;; Memory functions

(defun kill-any (any)
  (kill-new (format "%s" any))
  (message "Killed: %s" any))

;;;; Programming tools

(defun rgrep-current-word-in-el-project ()
  "Search with grep for the current word within my Emacs Lisp
project directory."
  (let* ((word (current-word t)) hyperscope
     (project rcd-current-project-directory)
     (fmt (format "grep --color --null -nH -ri -e \"%s\" *.el" word))) ;; TODO better quoting
    ;; and make defcustom for grep format
    (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-sql-timestamp ()
  (format-time-string "%Y-%m-%d %T"))

(defun rcd-read-time ()
  (let* ((date (calendar-read-date))
     (month (elt date 0))
     (day (elt date 1))
     (year (elt date 2)))
    (encode-time 0 0 0 day month year)))

(defun rcd-date-dir (&optional ask-for-date)
  "Returns the formatted date interactively asked"
  (if ask-for-date
      (format-time-string "%Y/%m/%Y-%m-%d/" (rcd-read-time))
    (format-time-string "%Y/%m/%Y-%m-%d/")))

(defun rcd-date-choice (&optional ask-for-date)
  "Returns the formatted date interactively asked"
  (if ask-for-date
      (format-time-string "%Y-%m-%d" (rcd-read-time))
    (format-time-string "%Y-%m-%d")))

;;; Graphics functions

(defun optimize-image-jpg (file)
  "Optimizes the JPG image with quality 70%"
  (let ((extension (file-name-extension file)))
    (when (equal (downcase extension) "jpg")
      (let* ((file (shell-double-quote file))
         (command (format "mogrify -sampling-factor 4:2:0 -strip -interlace JPEG -colorspace RGB -quality 70 \"%s\"" file)))
    (message command)
    (shell-command command)))))

(defun optimize-jpg-images-dired ()
  "Optimizes JPG images inside of Dired"
  (let ((files (dired-get-marked-files)))
    (dolist (file files)
      (optimize-image-jpg file))

(defun image-resize (file &optional size)
  "Resizes the JPG image with default size"
  (let ((extension (file-name-extension file)))
    (when (or (equal (downcase extension) "jpg")
          (equal (downcase extension) "png"))
      (let* ((file (shell-double-quote file))
         (command (format "mogrify -resize %s \"%s\"" size file)))
    (message command)
    (call-process-shell-command command)))))

(defun image-resize-dired ()
  "Resizes images"
  (let ((files (dired-get-marked-files))
    (size (read-number "Size: " *image-default-resize-size* '(*image-resize-sizes*))))
    (dolist (file files)
      (image-resize file size))

(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 "/")))

(provide 'rcd-utilities)

;;; rcd-utilities.el ends here

or download the file from:

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.

Related pages

Leave Your Comment or Contact GNU.Support

Contact GNU.Support now. There is a simple rule at GNU.Support: if we can help you, we do, whenever and wherever necessary, and it's the way we've been doing business since 2002, and the only way we know

Full name: