diff options
Diffstat (limited to '.emacs.d/lisp/my/my-utils.el')
| -rw-r--r-- | .emacs.d/lisp/my/my-utils.el | 409 |
1 files changed, 0 insertions, 409 deletions
diff --git a/.emacs.d/lisp/my/my-utils.el b/.emacs.d/lisp/my/my-utils.el deleted file mode 100644 index 7f36fae..0000000 --- a/.emacs.d/lisp/my/my-utils.el +++ /dev/null @@ -1,409 +0,0 @@ -;;; 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) |