Moving things one level deeper

To ease gnu stow usage. Now we can do

stow -t ~ emacs

1 files changed, 409 insertions, 0 deletions

diff --git a/emacs/.emacs.d/lisp/my/my-utils.el b/emacs/.emacs.d/lisp/my/my-utils.el
new file mode 100644
index 0000000..7f36fae
--- /dev/null
+++ b/emacs/.emacs.d/lisp/my/my-utils.el
@@ -0,0 +1,409 @@
+;;; my-utils.el -- Basic utilities used by other extensions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023 Free Software Foundation.
+
+;; Author: Yuchen Pei <id@ypei.org>
+;; Package-Requires: ((emacs "28.2"))
+
+;; This file is part of dotfiles.
+
+;; dotfiles is free software: you can redistribute it and/or modify it under
+;; the terms of the GNU Affero General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; dotfiles 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 Affero General
+;; Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public
+;; License along with dotfiles.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Basic utilities used by other extensions.
+
+;;; Code:
+
+
+;; time and date
+(defun my-date-part (td)
+  (nthcdr 3 td))
+
+(defun my-tomorrow ()
+  (decode-time (time-add 86400 (current-time))))
+
+(defun my-skip-http-header ()
+  (goto-char (point-min))
+  (re-search-forward "\r?\n\r?\n"))
+
+(defun my-seq-random-element (xs)
+  "Returns a random element of sequence."
+  (elt xs (random (length xs))))
+
+(defun my-delete-http-header ()
+  (delete-region (point-min) (progn (my-skip-http-header) (point))))
+
+(defun my-get-current-line-no-properties ()
+  (save-excursion
+    (let ((beg (progn (beginning-of-line)
+		                  (point)))
+	        (end (progn (beginning-of-line 2)
+		                  (point))))
+      (buffer-substring-no-properties beg (1- end)))))
+
+(defun my-sudo-find-file ()
+  (interactive)
+  (let* ((maybe-filename (thing-at-point 'filename t))
+	       (matched (and maybe-filename
+		                   (string-match "^\\(.*/\\)\\(.*\\)$" maybe-filename)))
+	       (file (read-file-name
+		            "Open as root: "
+		            (and matched (match-string 1 maybe-filename)) nil nil
+		            (and matched (match-string 2 maybe-filename)))))
+    (unless (file-writable-p file)
+      (find-file (concat "/sudo::" file)))))
+
+(defvar my-url-regexp
+  (concat
+   "~?\\<\\([-a-zA-Z0-9+&@#/%?=~_|!:,.;]*\\)"
+   "[.@]"
+   "\\([-a-zA-Z0-9+&@#/%?=~_|!:,.;]+\\)\\>/?")
+  "Regular expression to match (most?) URLs or email addresses.")
+
+
+(defun my-clean-property-value (value)
+  (when value
+    (replace-regexp-in-string
+     "\n" ", "
+     (string-trim (replace-regexp-in-string " " "_" value)
+		              "[ \t\n\r_]+" "[ \t\n\r_]+"))))
+
+;; rewriting urls
+(defvar my-max-url-rewrite 100 "Max number of URL redirect")
+(defun my-rewrite-url (url)
+  (let ((new-url url)
+        (tmp-url)
+        (i 0))
+    (catch 'done
+        (while (< i my-max-url-rewrite)
+          (setq tmp-url (my-rewrite-url-once new-url))
+          (when (equal tmp-url new-url) (throw 'done nil))
+          (setq new-url tmp-url
+                i (1+ i))))
+    (unless (equal url new-url)
+      (message "Rewriting %s to %s" url new-url))
+    new-url))
+
+(defvar my-simple-url-rewrites
+  '((:name http-to-https
+           :description "Rewrite http to https."
+           :from "^http://\\(.*\\)$"
+           :to "https://%s"
+           :parts (1))
+    (:name ddg-result
+           :description "duckduckgo result transform."
+           :from "^https://duckduckgo.com/l/\\?uddg=\\(.*\\)&rut=.*$"
+           :to "%s"
+           :parts (1)
+           :match-processor url-unhex-string)
+    (:name youtube-to-yewtu-be
+           :description "youtube to yewtu.be"
+           :from "^https://\\(www\\.\\)?youtube.com/\\(.*\\)$"
+           :to "https://yewtu.be/%s"
+           :parts (2))
+    (:name reddit-to-teddit
+           :description "Reddit to Teddit"
+           :from "^https://\\(www\\.\\|old\\.\\)?reddit.com/\\(.*\\)$"
+           :to "https://teddit.net/%s"
+           :parts (2))
+    (:name twitter-to-nitter
+           :description "Twitter to nitter."
+           :from "^https://twitter.com/\\(.*\\)$"
+           :to "https://nitter.eu/%s"
+           :parts (1))
+    (:name google-to-ddg
+           :description "Google to duckduckgo"
+           :from "^https://www.google.com/search\\?q=\\(.*\\)$"
+           :to "https://html.duckduckgo.com/html?q=%s"
+           :parts (1))
+    (:name php-manual-to-english
+           :descripton "PHP manual to English"
+           :from "^https://www.php.net/manual/../\\(.*\\)$"
+           :to "https://www.php.net/manual/en/%s"
+           :parts (1))
+    (:name google-sheets-to-csv
+           :description "Google sheets to csv"
+           :from "https://docs.google.com/spreadsheets/\\(.*\\)/.*"
+           :to "https://docs.google.com/spreadsheets/%s/export?format=csv"
+           :parts (1))
+    (:name google-docs-to-odt
+           :description "Google docs to odt"
+           :from "https://docs.google.com/document/\\(.*\\)/.*"
+           :to "https://docs.google.com/document/%s/export?format=odt"
+           :parts (1))
+    (:name utm-remover-not-last
+           :description "Removing a utm_foo query that is not the last query"
+           :from "\\(.*\\)\\butm_[a-z_]+=[^&]*&\\(.*\\)"
+           :to "%s%s"
+           :parts (1 2))
+    (:name utm-remover-last
+           :description "Removing a utm_foo query that is the last query"
+           :from "\\(.*\\)[&?]utm_[a-z_]+=[^#]*\\(.*\\)"
+           :to "%s%s"
+           :parts (1 2))))
+
+(defun my-simple-rewrite-function-name (data)
+  (intern (format "my-simple-url-rewrite-%s"
+                           (plist-get data :name))))
+
+(defmacro my-def-simple-rewrite (data)
+  (let ((processor (plist-get data :match-processor)))
+    `(defun ,(my-simple-rewrite-function-name data) (url)
+       ,(plist-get data :description)
+       (when (string-match ,(plist-get data :from) url)
+         ,(append `(format ,(plist-get data :to))
+                  (mapcar (lambda (part)
+                            (if processor
+                                `(,processor (match-string ,part url))
+                              `(match-string ,part url)))
+                          (plist-get data :parts)))))))
+
+;; TODO: why do we need an eval here?
+;; Because we are using plist-get in the defmacro
+(dolist (data my-simple-url-rewrites)
+  (eval `(my-def-simple-rewrite ,data)))
+
+(defvar my-url-rewrite-functions
+  (mapcar 'my-simple-rewrite-function-name my-simple-url-rewrites))
+
+(defun my-rewrite-url-once (url)
+  (let* ((rewriters my-url-rewrite-functions)
+         (rewritten) (rewriter) (result))
+    (while (and rewriters (not rewritten))
+      (setq rewriter (car rewriters)
+            rewriters (cdr rewriters)
+            rewritten (funcall rewriter url)))
+    (or rewritten url)))
+
+(defun my-shell-command-output (command)
+  (let ((inhibit-message t))
+    (if (= 0
+           (shell-command command))
+        (with-current-buffer shell-command-buffer-name
+          (string-trim (buffer-string)))
+      (error (with-current-buffer shell-command-buffer-name
+               (string-trim (buffer-string)))))))
+
+;; mailman utils
+(defun my-mailman-to-listinfo-url (url)
+  (when (string-match "^\\(.*\\)/archive/html/\\(.*\\)" url)
+    (format "%s/mailman/listinfo/%s"
+            (match-string 1 url) (match-string 2 url))))
+
+(defun my-mailman-to-archive-url (url)
+  (when (string-match "^\\(.*\\)/mailman/listinfo/\\(.*\\)" url)
+    (format "%s/archive/html/%s"
+            (match-string 1 url) (match-string 2 url))))
+
+;; filenames
+
+(defun my-make-filename (name &optional sep)
+  "Convert name to filename by replacing special chars with sep."
+  (unless sep (setq sep "-"))
+  (replace-regexp-in-string "[[:punct:][:space:]\n\r]+" sep
+                            (string-trim name)))
+
+(defun my-make-filename-from-url (url)
+  (let* ((urlobj (url-generic-parse-url url))
+         (filename (url-filename urlobj))
+         (host (url-host urlobj)))
+    (replace-regexp-in-string
+     "^-+" ""
+     (replace-regexp-in-string
+      "-+$" "" (my-make-filename (concat host "-" filename))))))
+
+(defun my-clean-property-key (key)
+  (when key
+    (let ((new-key
+	         (replace-regexp-in-string
+	          "[ \t\n\r_]+" "-" (string-trim
+			                         (replace-regexp-in-string " " "_" key)))))
+      (cond ((string-match "Publication-date" new-key)
+	           "Published")
+	          ((string= new-key "Publication") "Published")
+	          ((string= new-key "出版時間") "Published")
+	          ((string= new-key "出生") "Born")
+	          ((string= new-key "逝世") "Died")
+	          ((string= new-key "Formed") "Founded")
+	          ((string-match "^成立" new-key) "Founded")
+	          ((string= new-key "网站") "Website")
+	          ((string= new-key "網站") "Website")
+	          ((string= new-key "出版日期") "Published")
+	          ((string= new-key "Author") "Authors")
+	          ((string= new-key "作者") "Authors")
+	          ((string= new-key "Designer") "Designers")
+	          ((string-match "Directed" new-key) "Director")
+	          ((string= new-key "Created-by") "Director")
+	          ((string-match "导演" new-key) "Director")
+	          ((string-match "[Rr]elease-date" new-key) "Released")
+	          ((string-match "上映日期" new-key) "Released")
+	          ((string-match "[Oo]riginal-release" new-key) "Released")
+	          ((string-match "[Ii]nitial-release" new-key) "Released")
+	          ((string-match "^Release$" new-key) "Released")
+	          ((string-match "^Developer" new-key) "Developers")
+	          ((string-match "^Repository" new-key) "Source")
+	          ((string-match "^URL" new-key) "Website")
+	          ((string-match "^Official-website" new-key) "Website")
+	          (t new-key)))))
+
+(defun my-parse-colon-separated-output (buffer)
+  (with-current-buffer buffer
+    (goto-char (point-min))
+    (let ((result) (field) (value))
+      (while (not (eobp))
+	      (if (re-search-forward "\\(.*?\\)\\ +:" nil t)
+	          (progn
+	            (setq field
+		                (replace-regexp-in-string
+		                 "[()]" ""
+                     (replace-regexp-in-string "\\ " "-" (match-string 1))))
+	            (re-search-forward "\\ *\\(.*?\\)\n")
+	            (setq value (match-string 1))
+	            (push (cons field value) result))
+	        (message "Failed search in parsing!")
+	        (goto-char (point-max))))
+      result)))
+
+(defvar my-docs-root-dir nil "Root directory of documentation")
+(defun my-get-list-of-docs ()
+  (directory-files my-docs-root-dir nil directory-files-no-dot-files-regexp))
+
+(defmacro my-with-default-directory (dir &rest body)
+  "Run BODY with the default directory."
+  (declare (indent 1) (debug t))
+  `(let ((saved default-directory))
+     (setq default-directory ,dir)
+     ,@body
+     (setq default-directory saved)))
+
+(defun my-call-process-with-torsocks
+    (program &optional infile destination display &rest args)
+  (apply 'call-process
+         (append (list "torsocks" infile destination display program) args)))
+
+(defun my-start-process-with-torsocks (no-tor name buffer program &rest program-args)
+  (if no-tor
+      (apply 'start-process (append (list name buffer program) program-args))
+    (apply 'start-process
+           (append (list name buffer "torsocks" program) program-args))))
+
+(defun my-touch-new-file (filename)
+  "Touch a new file."
+  (with-temp-buffer (write-file filename)))
+
+(defvar my-extension-types
+  '((audio . ("asf" "cue" "flac" "m4a" "m4r" "mid" "mp3" "ogg" "opus"
+               "wav" "wma"))
+    (video . ("avi" "m4v" "mkv" "mp4" "mpg" "ogg" "ogv" "rmvb" "webm" "wmv"))))
+
+;;; files
+(defun my-rename-and-symlink-back (file newname ok-if-already-exists)
+  (when (directory-name-p newname)
+    (setq newname (concat newname (file-name-nondirectory file))))
+  (rename-file file newname ok-if-already-exists)
+  (make-symbolic-link newname file ok-if-already-exists)
+  newname)
+
+(defun my-rewrite-url-advice (args)
+  (let ((url (car args)))
+    (setcar args (my-rewrite-url url)))
+  args)
+
+(defun my-server-p ()
+  "nonnil if the emacs is a server or daemon"
+  (and (boundp 'server-process) server-process))
+
+;; cleaning utilities
+(defun my-extract-year (text)
+  (if (string-match "\\([0-9]\\{4\\}\\)" text)
+      (match-string 1 text)
+    ""))
+
+(defun my-rename-file-and-buffer (name)
+  "Apply NAME to current file and rename its buffer.
+Do not try to make a new directory or anything fancy."
+  (interactive
+   (list (read-file-name "Rename current file to: ")))
+  (let ((file (buffer-file-name)))
+    (if (vc-registered file)
+        (vc-rename-file file name)
+      (rename-file file name))
+    (set-visited-file-name name t t)))
+
+(defun my-delete-file-and-kill-buffer ()
+  "Delete the buffer and the file
+
+Only accept if the file is vc-registered (easy to recover from mistakes)"
+  (interactive)
+  (let ((file (buffer-file-name)))
+    (unless (vc-registered file)
+      (error "Cannot delete file not under vc"))
+    (vc-revert-file file)
+    (vc-refresh-state)
+    (vc-delete-file file))
+  (kill-buffer))
+
+;;; Some of the following functions are adapted from prot-dotfiles
+;;;###autoload
+(defun my-keyboard-quit-dwim ()
+  "Do-What-I-Mean behaviour for a general `keyboard-quit'.
+
+The generic `keyboard-quit' does not do the expected thing when
+the minibuffer is open.  Whereas we want it to close the
+minibuffer, even without explicitly focusing it.
+
+The DWIM behaviour of this command is as follows:
+
+- When the region is active, disable it.
+- When a minibuffer is open, but not focused, close the minibuffer.
+- When the Completions buffer is selected, close it.
+- In every other case use the regular `keyboard-quit'."
+  (interactive)
+  (cond
+   ((region-active-p)
+    (keyboard-quit))
+   ((derived-mode-p 'completion-list-mode)
+    (delete-completion-window))
+   ((> (minibuffer-depth) 0)
+    (abort-recursive-edit))
+   (t
+    (keyboard-quit))))
+
+;; The `my-line-regexp-p' and `my--line-regexp-alist'
+;; are contributed by Gabriel: <https://github.com/gabriel376>.
+(defvar my--line-regexp-alist
+  '((empty . "[\s\t]*$")
+    (indent . "^[\s\t]+")
+    (non-empty . "^.+$")
+    (list . "^\\([\s\t#*+]+\\|[0-9]+[^\s]?[).]+\\)")
+    (heading . "^[=-]+"))
+  "Alist of regexp types used by `my-line-regexp-p'.")
+
+(defun my-line-regexp-p (type &optional n)
+  "Test for TYPE on line.
+TYPE is the car of a cons cell in
+`my--line-regexp-alist'.  It matches a regular
+expression.
+
+With optional N, search in the Nth line from point."
+  (save-excursion
+    (goto-char (line-beginning-position))
+    (and (not (bobp))
+         (or (beginning-of-line n) t)
+         (save-match-data
+           (looking-at
+            (alist-get type my--line-regexp-alist))))))
+
+(provide 'my-utils)