diff options
Diffstat (limited to 'emacs/.emacs.d/lisp/my')
29 files changed, 2797 insertions, 363 deletions
diff --git a/emacs/.emacs.d/lisp/my/belf.el b/emacs/.emacs.d/lisp/my/belf.el new file mode 100644 index 0000000..0db79f6 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/belf.el @@ -0,0 +1,536 @@ +;;; belf.el -- Bookshelf, ebook library management -*- lexical-binding: t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "29.4")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Bookshelf, ebook library management. + +;;; Code: + +(require 'tabulated-list) +(require 'infobox) +(require 'my-epub) + +(defvar-keymap belf-mode-map + :parent tabulated-list-mode-map + "F" #'belf-toggle-follow-mode + "RET" #'belf-open-book + "b" #'tabulated-list-previous-column + "d" #'belf-show-in-dired + "f" #'tabulated-list-next-column + "i" #'belf-book-infobox-at-point + "n" #'belf-next-line + "o" #'belf-open-book-other-window + "p" #'belf-previous-line + "e" #'belf-set-field + "," #'belf-rename-desort-at-point + "E" #'belf-epub-rename-at-point + ;; "s" #'tabulated-list-col-sort + ) + +(define-derived-mode belf-mode tabulated-list-mode "Bookshelf" + "Major mode for browsing a list of books." + (setq tabulated-list-format + [("Authors" 25 belf-compare-authors) + ("Title" 48 belf-compare-title) + ("Year" 4 t)]) + (setq tabulated-list-padding 2) + (tabulated-list-init-header) + (setq revert-buffer-function #'belf-list-refresh-contents) + (hl-line-mode)) + +(defun belf () + (interactive) + (let ((buf (get-buffer-create "*Bookshelf*"))) + (with-current-buffer buf + (belf-mode) + (belf-list-refresh-contents)) + (pop-to-buffer-same-window buf))) + +(defun belf-library (dir) + (interactive (list (read-directory-name "Book directory: " belf-dir nil t))) + (setq belf-dir dir) + (belf)) + +(defun belf-list-refresh-contents (&rest _) + (setq-local tabulated-list-entries (belf-parse-all-file-names)) + (tabulated-list-print)) + +(defvar belf-dir "~/Documents" "Directory of books.") + +(defun belf-parse-file-names (file-names) + (seq-filter + #'identity + (seq-map + (lambda (f) + (when-let ((parsed (belf-parse-file-name f))) + (let-alist parsed + (list f (vector .authors .title .year))))) + file-names))) + +(defun belf-parse-all-file-names () + (belf-parse-file-names (directory-files belf-dir t "\\.\\(epub\\|pdf\\|cbr\\|djvu\\|mobi\\|azw3\\)$"))) + +(defun belf-file-name-desort (file-name new-dir) + "Rename a file. + +Change authors-sort to authors. Change title-sort to title. + +Test: +foo bar +foo, bar +foo bar, quux baf +foo, bar & quux, baf +foo bar & quux, baf" + (when-let ((parsed (belf-parse-file-name file-name))) + (let* ((authors (string-split (alist-get 'authors parsed) " & " t " +")) + (title (alist-get 'title parsed))) + (setf + (alist-get 'authors parsed) + (mapconcat + (lambda (author) + (let ((comma-split (string-split author ", "))) + (if (or ;; no comma or more than one comma + (/= (length comma-split) 2) + ;; at least one space before the comma + (string-match-p " " (car comma-split))) + author + ;; from author-sort to author + (format "%s %s" (cadr comma-split) (car comma-split)) + ))) + authors + ", ") + (alist-get 'title parsed) + (cond ((string-suffix-p ", The" title) + (concat "The " (string-remove-suffix ", The" title))) + ((string-suffix-p ", A" title) + (concat "A " (string-remove-suffix ", A" title))) + (t title)))) + (format "%s.%s" + (belf-format-base-name parsed new-dir) + (alist-get 'ext parsed)))) + +(defun belf-rename-desort (file-name new-dir) + (when-let ((new-name (belf-file-name-desort file-name new-dir))) + (unless (equal new-name file-name) + (rename-file file-name new-name)))) + +(defun belf-rename-desort-at-point () + (interactive) + (let ((file-name (tabulated-list-get-id))) + (belf-rename-desort file-name (file-name-directory file-name)) + (revert-buffer))) + +(defun belf-rename-desort-files (dir new-dir) + (interactive) + (dolist (file-name + (directory-files dir t directory-files-no-dot-files-regexp)) + (belf-rename-desort file-name new-dir))) + +(defun belf-epub-rename-files (dir new-dir) + (dolist (epub (directory-files dir t "\\.epub$")) + (belf-epub-rename epub new-dir))) + +(defun belf-epub-rename (file-name new-dir) + (when-let ((meta (my-epub-metadata file-name))) + (let* ((dir (file-name-directory file-name)) + (new-base-name (belf-format-base-name meta new-dir)) + new-name) + (dolist (file (directory-files dir t + (format "^%s\\.[a-zA-Z0-9]+$" + (regexp-quote + (file-name-base file-name))))) + (setq new-name (format "%s.%s" new-base-name (file-name-extension file))) + (unless (equal file-name new-name) + (message "%s -> %s" file new-name) + (ignore-error 'file-already-exists (rename-file file new-name)) + ) + ) + ) + )) + +(defun belf-move-invalid-file-names (dir new-dir) + "Move files in DIR whose file names do not validate to NEW-DIR." + (let (new-name) + (dolist (file-name (directory-files dir t directory-files-no-dot-files-regexp)) + (unless (string-match-p "^.*? +- +.* +([0-9]*) +\\[.*\\]\\.[a-zA-Z0-9]+$" file-name) + (message "%s -> %s" file-name + (setq new-name (file-name-concat + new-dir (file-name-nondirectory file-name)))) + (rename-file file-name new-name) + )))) + +(defun belf-dired-do-epub-rename () + (interactive) + (seq-do + (lambda (file) + (when (equal (upcase (file-name-extension file)) "EPUB") + (belf-epub-rename file (file-name-directory file)))) + (dired-get-marked-files))) + +(defun belf-epub-rename-at-point () + (interactive) + (let ((file-name (tabulated-list-get-id))) + (belf-epub-rename file-name (file-name-directory file-name)) + (revert-buffer))) + +(defun belf-parse-file-name (file-name) + (let ((fn (file-name-nondirectory file-name))) + (when (string-match "^\\(.*?\\) +- +\\(.*\\) +(\\([0-9]*\\)) +\\[\\(.*\\)\\]\\.\\([a-zA-Z0-9]+\\)$" fn) + `((authors . ,(match-string 1 fn)) + (title . ,(match-string 2 fn)) + (year . ,(match-string 3 fn)) + (identifier . ,(match-string 4 fn)) + (ext . ,(match-string 5 fn)))))) + +(defun belf-format-base-name (info &optional dir) + (let-alist info + (file-name-concat + (expand-file-name (or dir belf-dir)) + (replace-regexp-in-string + "[/:?*\"]" "_" + (format "%s - %s (%s) [%s]" .authors .title .year .identifier))))) + +(defun belf-book-infobox (file-name) + (interactive) + (belf-book-render-info (belf-exiftool-info file-name) file-name)) + +(defvar belf-exiftool-program "exiftool" "The exiftool program.") + +(defun belf-exiftool-info (file-name) + "Given a video URL, return an alist of its properties." + (with-temp-buffer + (call-process belf-exiftool-program nil t nil "-j" file-name) + (let ((start (point))) + (call-process-region + nil nil "jq" nil t nil + ".[0]|pick(.Title, .Author, .Creator, .Keywords, .Subject, .Publisher, .Identifier, .Series, .Title_sort, .Author_sort, .PageCount, .FileSize, .ISBN, .Language, .FileType, .Description)") + (goto-char start) + (json-read))) + ) + +(defun belf-epub-cover-file-name (file-name content-file-name) + (with-temp-buffer + (call-process "unzip" nil t nil "-p" file-name content-file-name) + (let* ((dom (libxml-parse-xml-region (point-min) (point-max))) + (metas + (dom-by-tag (dom-by-tag (dom-by-tag dom 'package) 'metadata) 'meta)) + (items + (dom-by-tag (dom-by-tag (dom-by-tag dom 'package) 'manifest) 'item)) + cover-name + cover-file + cover-file-from-prop) + (while (and metas (not cover-name)) + (let-alist (cadr (car metas)) + (when (equal .name "cover") + (setq cover-name .content))) + (setq metas (cdr metas))) + (while (and items (not cover-file)) + (let-alist (cadr (car items)) + (when (equal .id cover-name) + (setq cover-file .href)) + (when (equal .properties "cover-image") + (setq cover-file-from-prop .href))) + (setq items (cdr items))) + (cond (cover-file + (file-name-concat (file-name-directory content-file-name) + cover-file)) + (cover-file-from-prop + (file-name-concat (file-name-directory content-file-name) + cover-file-from-prop)) + ((not cover-name) + (message "Could not find cover in epub metadata.") + nil) + ;; If no cover-file, then try cover-name if it looks like + ;; an image file path + ((string-match-p belf-book-cover-re cover-name) + (file-name-concat (file-name-directory content-file-name) + cover-name))) + ))) + +(defvar belf-book-cover-exts '("jpg" "png" "jpeg")) +(defvar belf-book-cover-re + (concat "^.*\\." (regexp-opt belf-book-cover-exts) "$")) + +(defun belf-locate-book-cover (file-name) + (let ((exts belf-book-cover-exts) + cover-file-name + found) + (while (and exts (not found)) + (setq cover-file-name (file-name-with-extension file-name (car exts)) + exts (cdr exts) + found (file-exists-p cover-file-name))) + (when found cover-file-name))) + +(defun belf-pdf-page-one-cover (file-name) + "Extract the first page of a pdf file as cover." + (let ((cover-file (file-name-with-extension file-name "jpg"))) + (with-temp-buffer + (if (eq 0 + (call-process "gs" nil t t + "-dNOPAUSE" "-dBATCH" "-sDEVICE=jpeg" "-r300" + (format "-sOutputFile=%s" cover-file) + "-dFirstPage=1" "-dLastPage=1" file-name)) + cover-file + (message "Failed to extract cover from PDF: %s" (buffer-string)) + nil)))) + +(defun belf-book-cover (file-name) + "Get book cover. + +First look for an image file with the same file name. +Then for PDF, extract the first page. +For EPUB, looks for a cover image in the file." + (if-let ((cover-file-name (belf-locate-book-cover file-name))) + (concat "file://" cover-file-name) + (cond ((equal "epub" (file-name-extension file-name)) + (when-let* ((content-file-name (belf-epub-content-file-name file-name)) + (cover-file + (belf-epub-cover-file-name file-name content-file-name)) + (cover-file-name (file-name-with-extension + file-name + (file-name-extension cover-file)))) + (call-process "unzip" nil `(:file ,cover-file-name) nil + "-p" file-name cover-file) + (format "file://%s" cover-file-name))) + ((equal "pdf" (file-name-extension file-name)) + (when (setq cover-file-name (belf-pdf-page-one-cover file-name)) + (format "file://%s" cover-file-name)))))) + +(defun belf-set-field () + (interactive) + (cond ((equal "Authors" + (get-text-property (point) 'tabulated-list-column-name)) + (call-interactively 'belf-set-authors)))) + +(defun belf-set-authors (new-authors) + (interactive + (list + (read-string "Set authors to: " + (alist-get 'authors (belf-parse-file-name + (tabulated-list-get-id)))))) + (let* ((file-name (tabulated-list-get-id)) + (dir (file-name-directory file-name)) + (parsed (belf-parse-file-name file-name)) + new-base-name + new-file) + (setf (alist-get 'authors parsed) new-authors) + (setq new-base-name (belf-format-base-name parsed dir)) + (dolist (file (directory-files dir t + (format "^%s\\.[a-zA-Z0-9]+$" + (regexp-quote + (file-name-base file-name))))) + (setq new-file (format "%s.%s" new-base-name (file-name-extension file))) + (message "%s -> %s" file new-file) + (rename-file file new-file)) + (revert-buffer))) + +(defun belf-parse-first-author-name (authors) + "Returns (last-name . first-name) of the first author of AUTHORS." + (when (string-match-p))) + +(defun belf-compare-authors (x y) + "Authors comparator. + +Authors are in the format of +fname1 lname1, fname2 lname2, ..." + (string< + (car (last (string-split (car (string-split (elt (cadr x) 0) ", ")) " "))) + (car (last (string-split (car (string-split (elt (cadr y) 0) ", ")) " "))))) + +(defun belf-compare-title (x y) + "Title comparator. + +Compare without leading \"The \"." + (string< + (string-remove-prefix "The " (elt (cadr x) 1)) + (string-remove-prefix "The " (elt (cadr y) 1)))) + +(defun belf-book-infobox-at-point () + (interactive) + (let ((help-window-select (not belf-follow-mode))) + (belf-book-infobox (tabulated-list-get-id))) + ) + +(defun belf-book-render-info (info file-name) + (setf (alist-get 'Title info) + (concat (alist-get 'Title info) + " -- " + (buttonize "context" + (lambda (_) + (funcall my-file-context-function file-name))) + " " (buttonize "find-file" (lambda (_) (find-file file-name)))) + (alist-get 'Thumbnail info) + (belf-book-cover file-name) + (alist-get 'Description info) + (when-let ((text (alist-get 'Description info))) + (with-temp-buffer + (insert + (if (stringp text) text (prin1-to-string text))) + (shr-render-region (point-min) (point-max)) + (goto-char (point-min)) + (insert "\n") + (buffer-string)))) + (infobox-render + (infobox-translate info (infobox-default-specs info)) + `(belf-book-infobox ,file-name) + (called-interactively-p 'interactive))) + +(defvar belf-follow-mode nil "Whether follow mode is on.") + +(defun belf-toggle-follow-mode () + (interactive) + (setq belf-follow-mode (not belf-follow-mode))) + + +(defun belf-previous-line () + (interactive) + (previous-line) + (when belf-follow-mode + (belf-book-infobox-at-point))) + +(defun belf-next-line () + (interactive) + (next-line) + (when belf-follow-mode + (belf-book-infobox-at-point))) + +(defun belf-show-in-dired () + (interactive) + (dired-jump-other-window (tabulated-list-get-id))) + +(defun belf-open-book () + (interactive) + (find-file (tabulated-list-get-id))) + +(defun belf-open-book-other-window () + (interactive) + (find-file-other-window (tabulated-list-get-id))) + +;;; belf-recent + +(defvar belf-recent-file (locate-user-emacs-file "belf-list")) + +(defun belf-recent-add (file) + "Add FILE to `belf-recent-file'. + +Can be used as a `find-file-hook'." + (when (string-match-p "\\.\\(epub\\|pdf\\|cbr\\|djvu\\|mobi\\|azw3\\)$" + file) + (with-temp-buffer + (when (file-exists-p belf-recent-file) + (insert-file-contents belf-recent-file)) + (goto-char (point-min)) + (flush-lines (rx-to-string `(and bol "[" (= 23 anychar) "] " ,file eol))) + (insert + (format-time-string "[%Y-%m-%d %a %H:%M:%S]" (current-time)) + " " + file + "\n") + (write-file belf-recent-file) + ))) + +(defun belf-recent-add-current () + (when buffer-file-name + (belf-recent-add buffer-file-name))) + +(define-derived-mode belf-recent-mode belf-mode "Bookshelf Recent" + "Major mode for browsing a list of books." + (setq revert-buffer-function #'belf-recent-list-refresh-contents)) + +(defun belf-recent () + (interactive) + (let ((buf (get-buffer-create "*Bookshelf Recent*"))) + (with-current-buffer buf + (belf-recent-mode) + (belf-recent-list-refresh-contents)) + (pop-to-buffer-same-window buf))) + +;; (defvar belf-find-dir nil +;; "Directory to run find command for relocated files.") + +(defvar belf-locate-dirs nil + "Directories to look for relocated files.") + +(defun belf-recent-bookkeeping () + "Check `belf-recent-file' for (re)moved files and update accordingly." + (interactive) + (copy-file belf-recent-file (concat belf-recent-file ".bak") t) + (with-temp-buffer + (when (file-exists-p belf-recent-file) + (insert-file-contents belf-recent-file)) + (goto-char (point-min)) + (while (not (eobp)) + (forward-char 26) + (let* ((beg (point)) + (end (progn (end-of-line) (point))) + (file-name (buffer-substring-no-properties beg end))) + (unless (file-exists-p file-name) + (let ((dirs belf-locate-dirs) + (file-name-nodir (file-name-nondirectory file-name)) + dir new-name found) + (delete-region beg end) + (while (and (not found) dirs) + (setq dir (expand-file-name (car dirs)) + new-name (file-name-concat dir file-name-nodir) + found (file-exists-p new-name) + dirs (cdr dirs))) + (when found (insert new-name))) + ;; Running find on a big dir is too slow even when there are + ;; only a few thousands subdirs + ;; (call-process "find" nil (current-buffer) nil + ;; (expand-file-name belf-find-dir) + ;; "-name" (file-name-nondirectory file-name)) + ) + (beginning-of-line 2))) + + ;; Remove empty records that could not be found + (goto-char (point-min)) + (flush-lines (rx bol (= 26 anychar) eol)) + + ;; Deduplicate + (goto-char (point-min)) + (while (not (eobp)) + (forward-char 26) + (let* ((beg (point)) + (end (progn (end-of-line) (point))) + (file-name (buffer-substring-no-properties beg end))) + (flush-lines + (rx-to-string `(and bol "[" (= 23 anychar) "] " ,file-name eol)))) + (beginning-of-line 2)) + (write-file belf-recent-file))) + +(defun belf-recent-list-refresh-contents (&rest _) + (belf-recent-bookkeeping) + (setq-local tabulated-list-entries (belf-recent-parse-file-names)) + (tabulated-list-print)) + +(defun belf-recent-parse-file-names () + (with-temp-buffer + (when (file-exists-p belf-recent-file) + (insert-file-contents belf-recent-file)) + (goto-char (point-min)) + (replace-regexp (rx bol (= 26 anychar)) "") + (belf-parse-file-names (string-lines (buffer-string)))) + ) + +(provide 'belf) diff --git a/emacs/.emacs.d/lisp/my/fediorg.el b/emacs/.emacs.d/lisp/my/fediorg.el new file mode 100644 index 0000000..e2f21b8 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/fediorg.el @@ -0,0 +1,368 @@ +;;; fediorg.el -- Read and archive fedi post context in org mode -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "28.2")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Read or archive a fedi thread context in org mode. This is a +;; standalone library, and can be used without any other files in this +;; project. + +;; Usage: +;; M-x fediorg-open <RET> https://pleroma.instance/notice/... <RET> +;; M-x fediorg-open <RET> https://mastodon.instance/@user/... <RET> +;; +;; The post, together with its ancestors and descendants, subject to +;; the API depth limit, are displayed in an org buffer. + +;; TODO: +;; +;; To be able to refresh the org buffer at an org entry, which would +;; re-fetch the context of the corresponding post and upsert them in +;; the buffer. +;;; Code: + + +(require 'hierarchy) +(require 'json) +(require 'url-parse) + +(defvar fediorg-buffer "*fediorg*" "Buffer name for fediorg buffers.") + +;;; Fetching utilities +(defvar fediorg-client-buffer-name "*fediorg-api*" + "Buffer name for logging API requests.") + +(defun fediorg-url-fetch-json (url &optional decompression with-header) + "Fetch and parse json from URL. + +With nonnil DECOMPRESSION, gunzip the response first. +With nonnil WITH-HEADER, include the response headers in the return value." + (fediorg-url-fetch-internal + url + (lambda () + (json-read-from-string (decode-coding-string (buffer-string) 'utf-8))) + decompression + with-header)) + +(defun fediorg-url-fetch-internal (url buffer-processor decompression with-header) + "Fetch from URL and process the response with BUFFER-PROCESSOR. + +With nonnil DECOMPRESSION, gunzip the response first. +With nonnil WITH-HEADER, include the response headers in the return value." + (with-current-buffer (get-buffer-create fediorg-client-buffer-name) + (goto-char (point-max)) + (insert "[" (current-time-string) "] Request: " url "\n")) + (with-current-buffer (url-retrieve-synchronously url t) + (let ((header (fediorg-kill-http-header)) (status) (fields)) + (goto-char (point-min)) + (setq header (fediorg-parse-http-header header) + status (alist-get 'status header) + fields (alist-get 'fields header)) + (with-current-buffer fediorg-client-buffer-name + (insert "[" (current-time-string) "] Response: " status "\n")) + (when decompression + (call-process-region (point) (point-max) "gunzip" t t t) + (goto-char (point-min))) + (call-interactively 'delete-trailing-whitespace) + (if (string= status "200") + (unless (= (point) (point-max)) + (if with-header + (list + (cons 'header fields) + (cons 'json (funcall buffer-processor))) + (funcall buffer-processor))) + (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) + +(defun fediorg-kill-http-header () + "Kill http headers in the current buffer." + (fediorg-skip-http-header) + (let ((killed (buffer-substring-no-properties (point-min) (point)))) + (delete-region (point-min) (point)) + killed)) + +(defun fediorg-skip-http-header () + "Skip http headers in the current buffer." + (goto-char (point-min)) + (re-search-forward "\r?\n\r?\n")) + +(defun fediorg-parse-http-header (text) + "Parse http headers from TEXT in the current buffer." + (let ((status) (fields)) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$") + (setq status (match-string 1)) + (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t) + (push (cons (intern (match-string 1)) (match-string 2)) fields))) + (list (cons 'status status) (cons 'fields fields)))) + +;;; utilities +(defun fediorg-api-search (host url) + (fediorg-url-fetch-json + (format "https://%s/api/v2/search/?q=%s&resolve=true" host url))) + +(defun fediorg-canonical-post-url-by-search (host url) + (let-alist (fediorg-api-search host url) + (if (seq-empty-p .statuses) + (error "No statuses associated with URL %s" url) + (fediorg-canonical-post-url (alist-get 'url (elt .statuses 0)) t)))) + +(defun fediorg-post-url-p (url &optional no-fetch) + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (or (string-match-p "^/objects/[-a-f0-9]+$" path) + (string-match-p + "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path) + (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path) + (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path)))) + +(defun fediorg-canonical-post-url (url &optional no-fetch) + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (cond ((or (string-match-p "^/objects/[-a-f0-9]+$" path) + (string-match-p + "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path)) + (unless no-fetch (fediorg-canonical-post-url-by-search host url))) + ((or (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path) + (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path)) + url) + (t (error "Unrecognisable URL: %s" url))))) + +(defun fediorg-parse-url (url) + "Parse fedi post URL." + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj)) + (host (url-host urlobj))) + (cons host (caddr (split-string path "/"))))) + +(defun fediorg-api-status (url) + "Get the status given URL." + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (fediorg-url-fetch-json + (format "https://%s/api/v1/statuses/%s" host post-id)))) + +(defun fediorg-api-status-context (url) + "Get the status context given URL." + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (fediorg-url-fetch-json + (format "https://%s/api/v1/statuses/%s/context" host post-id)))) + +(defun fediorg-get-first-ancestor (url) + "Given a fedi post URL, return the url of its first ancestor." + (let ((ancestors + (alist-get 'ancestors (fediorg-api-status-context url)))) + (if (length> ancestors 0) + (alist-get 'url (elt ancestors 0)) + url))) + +(defun fediorg-post-make-parent-fn (posts) + "Given a collection of POSTS, return a function that find the parent post." + (lambda (post) + (let ((id (alist-get 'in_reply_to_id post))) + (seq-find + (lambda (candidate) + (equal (alist-get 'id candidate) id)) + posts)))) + +;;; Formatting functions +(defun fediorg-format-post-tree (url) + "Format a post tree of post located at URL. + +Including ancestors and descendants, if any." + (let* ((posts-hier (hierarchy-new)) + (context-posts (fediorg-api-status-context url)) + (posts (vconcat + (alist-get 'ancestors context-posts) + (vector (fediorg-api-status url)) + (alist-get 'descendants context-posts)))) + (hierarchy-add-trees + posts-hier + posts + (fediorg-post-make-parent-fn posts)) + (string-join + (hierarchy-map 'fediorg-format-post posts-hier 1) + "\n"))) + +(defun fediorg-make-org-link (link desc) + (format "[[%s][%s]]" link desc)) + +(defun fediorg-format-attached (attachments host) + (mapconcat + (lambda (attachment) + (let-alist attachment + (with-temp-buffer + (insert + (fediorg-make-org-link .url .type)) + (when .description + (insert ": " .description)) + (when .preview_url + (let ((thumb-file-name + (file-name-concat + fediorg-dir + (format "%s.%s.%s" host .id + (file-name-extension .preview_url))))) + (ignore-error 'file-already-exists + (url-copy-file .preview_url thumb-file-name)) + (insert "\n") + (when-let ((image (create-image thumb-file-name))) + (insert-image image)) + )) + (buffer-string)))) + attachments + "\n")) + +(defun fediorg-format-post (post level) + "Format a POST with indent LEVEL." + (let-alist post + (let ((host (car (fediorg-parse-url .url)))) + (format "%s %s (@%s@%s) %s\n\n%s%s\n\n⤷%d ⇆%d ★%d\n" + (make-string level ?*) + (if (string-empty-p .account.display_name) + .account.username .account.display_name) + .account.username + host + (fediorg-make-org-link + .url + (fediorg--relative-time-description .created_at)) + (with-temp-buffer + (insert .content) + (shr-render-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) (point-max))) + (fediorg-format-attached .media_attachments host) + .replies_count + .reblogs_count + .favourites_count)))) + +(defun fediorg-save-text-and-switch-to-buffer (text file-name) + "Save TEXT to FILE-NAME and switch to buffer." + (let ((buffer (find-file-noselect file-name)) + (coding-system-for-write 'utf-8)) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert text)) + (goto-char (point-min)) + (save-buffer) + (revert-buffer t t)) + (switch-to-buffer buffer))) + +(defvar fediorg-dir (locate-user-emacs-file "fediorg") + "Path to local directory of saved threads.") + +(defun fediorg-make-post-file-name (url) + (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url))) + (format "%s.%s.org" host post-id))) + +;;;###autoload +(defun fediorg-open (url) + "Given a fedi post URL, open an org buffer rendering the post. + +Including the context, i.e. ancestors and descendant posts." + (interactive "sPost URL: ") + (setq url (fediorg-canonical-post-url url)) + (fediorg-save-text-and-switch-to-buffer + (fediorg-format-post-tree url) + (file-name-concat fediorg-dir (fediorg-make-post-file-name url)))) + +;;; code adapted from mastodon.el +(defun fediorg--human-duration (seconds &optional resolution) + "Return a string describing SECONDS in a more human-friendly way. +The return format is (STRING . RES) where RES is the resolution of +this string, in seconds. +RESOLUTION is the finest resolution, in seconds, to use for the +second part of the output (defaults to 60, so that seconds are only +displayed when the duration is smaller than a minute)." + (cl-assert (>= seconds 0)) + (unless resolution (setq resolution 60)) + (let* ((units fediorg--time-units) + (n1 seconds) (unit1 (pop units)) (res1 1) + n2 unit2 res2 + next) + (while (and units (> (truncate (setq next (/ n1 (car units)))) 0)) + (setq unit2 unit1) + (setq res2 res1) + (setq n2 (- n1 (* (car units) (truncate n1 (car units))))) + (setq n1 next) + (setq res1 (truncate (* res1 (car units)))) + (pop units) + (setq unit1 (pop units))) + (setq n1 (truncate n1)) + (if n2 (setq n2 (truncate n2))) + (cond + ((null n2) + ;; revert to old just now style for < 1 min: + (cons "just now" 60)) + ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + ;; (max resolution res1))) + ((< (* res2 n2) resolution) + (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + (max resolution res2))) + ((< res2 resolution) + (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2))) + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + resolution))) + (t + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + (max res2 resolution)))))) + +(defconst fediorg--time-units + '("sec" 60.0 ;; Use a float to convert `n' to float. + "min" 60 + "hour" 24 + "day" 7 + "week" 4.345 + "month" 12 + "year")) + +(defun fediorg--relative-time-details (timestamp &optional current-time) + "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +The descriptive string is a human readable version relative to +the current time while the next change timestamp give the first +time that this description will change in the future. +TIMESTAMP is assumed to be in the past." + (let* ((time-difference (time-subtract current-time timestamp)) + (seconds-difference (float-time time-difference)) + (tmp (fediorg--human-duration (max 0 seconds-difference)))) + ;; revert to old just now style for < 1 min + (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago")) + (time-add current-time (cdr tmp))))) + +(defun fediorg--relative-time-description (time-string &optional current-time) + "Return a string with a human readable TIME-STRING relative to the current time. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +E.g. this could return something like \"1 min ago\", \"yesterday\", etc. +TIME-STAMP is assumed to be in the past." + (car (fediorg--relative-time-details + (encode-time (parse-time-string time-string)) current-time))) + +(provide 'fediorg) +;;; fediorg.el ends here diff --git a/emacs/.emacs.d/lisp/my/infobox.el b/emacs/.emacs.d/lisp/my/infobox.el new file mode 100644 index 0000000..ff4adb6 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/infobox.el @@ -0,0 +1,174 @@ +;;; infobox.el -- Infobox in a help buffer -*- lexical-binding: t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "29.4")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Infobox in a help buffer. + +;;; Code: + + +(defun infobox-transform-field-value (v) + (cond ((stringp v) v) + ((eq v t) "YES") + ((eq v :json-false) "NO") + ((seqp v) + (mapconcat + (lambda (x) (if (stringp x) x (prin1-to-string x))) + v + ", ")) + (t (format "%s" v)))) + +(defun infobox-default-specs (info) + (seq-map + (lambda (pair) + (cons (car pair) + (replace-regexp-in-string + "[-_]" " " + (capitalize (format "%s" (car pair)))))) + info)) + +(defun infobox-translate (info specs) + "Translate INFO according to SPECS. + +TODO: allow multiple levels in specs keys using let-alist, i.e. +something like + +(.channel.name . \"Channel name\")" + (seq-map + (lambda (pair) + (when-let ((val (alist-get (car pair) info))) + (if (or (stringp (cdr pair)) (symbolp (cdr pair))) + (cons (cdr pair) (infobox-transform-field-value val)) + (cons (cadr pair) (funcall (cddr pair) val))))) + specs)) + +(defun infobox-render (info item &optional interactive-p) + "Render and display a help buffer of INFO." + (with-help-window "*infobox*" + (with-current-buffer standard-output + (let ((n-rows 0)) + ;; TODO: use a more standard function than + ;; `my-make-filename-from-url' + (when-let* ((thumb-url (alist-get "Thumbnail" info nil nil 'equal)) + (file-name + (if (string-prefix-p "file://" thumb-url) + (string-remove-prefix "file://" thumb-url) + (make-temp-name "/tmp/infobox-")))) + (unless (string-prefix-p "file://" thumb-url) + (url-copy-file thumb-url file-name t)) + (insert-image (create-image file-name nil nil + :max-width (window-pixel-width) + :max-height (/ (window-pixel-height) 2))) + (insert "\n") + (setq n-rows (1+ n-rows)) + (setq info (assoc-delete-all "Thumbnail" info)) + ) + (seq-do + (lambda (pair) + (when pair + (when (stringp (car pair)) + (insert (car pair) ": ") + (setq n-rows (1+ n-rows))) + (insert (format "%s" (cdr pair)) "\n"))) + info) + (align-regexp + (point-min) + (progn (goto-line (1+ n-rows)) (point)) + "\\(\\s-*\\):")) + (visual-line-mode))) + (with-current-buffer "*infobox*" + (let ((help-xref-following t)) + (help-setup-xref item interactive-p) + ))) + +(defun infobox-render-string (text item &optional interactive-p) + (help-setup-xref item interactive-p) + (with-help-window "*infobox*" + (with-current-buffer standard-output + (insert text) + (visual-line-mode))) + (with-current-buffer "*infobox*" + (let ((help-xref-following t)) + (help-setup-xref item interactive-p) + ))) + +(defun infobox-exiftool (filename) + (interactive (list (expand-file-name (read-file-name "infobox exiftool: ")))) + (infobox-render-string + (with-temp-buffer + (call-process "exiftool" nil t nil filename) + (goto-char (point-min)) + (flush-lines "ExifTool Version") + (end-of-line) + (insert " -- " (buttonize + "xdg-open" + (lambda (_) (call-process "xdg-open" nil 0 nil filename))) + " " (buttonize "find-file" (lambda (_) (find-file filename)))) + (buffer-string)) + `(infobox-exiftool ,filename) + (called-interactively-p 'interactive) + )) + +(defun infobox-pacman (package-name) + (interactive (list (completing-read + "pacman package: " + (infobox-pacman-installed-packages) + nil + t))) + (infobox-render-string + (with-temp-buffer + (call-process "pacman" nil t nil "-Qi" package-name) + (buffer-string)) + `(infobox-pacman ,package-name) + (called-interactively-p 'interactive) + )) + +(defun infobox-pacman-installed-packages () + "Returns list of installed packages." + (with-temp-buffer + (call-process "pacman" nil t nil "-Qq") + (split-string (buffer-string) "\n"))) + +(defun infobox-calibre (book-id) + (interactive (list (car (split-string + (completing-read + "calibre book: " + (infobox-calibre-books) + nil + t) + " ")))) + (infobox-render-string + (with-temp-buffer + (call-process "calibredb" nil t nil "show_metadata" book-id) + (buffer-string)) + `(infobox-calibre ,book-id) + (called-interactively-p 'interactive))) + +(defun infobox-calibre-books () + (with-temp-buffer + (call-process "calibredb" nil t nil "list") + (seq-filter + (lambda (line) (string-match-p "^[0-9]" line)) + (split-string (buffer-string) "\n")))) + +(provide 'infobox) diff --git a/emacs/.emacs.d/lisp/my/mastorg.el b/emacs/.emacs.d/lisp/my/mastorg.el deleted file mode 100644 index 3544b2e..0000000 --- a/emacs/.emacs.d/lisp/my/mastorg.el +++ /dev/null @@ -1,207 +0,0 @@ -;;; mastorg.el -- Read or archive mastodon toot context in org mode -*- lexical-binding: t -*- - -;; Copyright (C) 2023 Free Software Foundation, Inc. - -;; Author: Yuchen Pei <id@ypei.org> -;; Package-Requires: ((emacs "28.2")) - -;; This file is part of dotted. - -;; dotted 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. - -;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Read or archive mastodon toot context in org mode. This is a -;; standalone library, and can be used without any other files in this -;; project. - -;; Usage: -;; M-x mastorg-open <RET> https://mastodon.instance/@user/12345678901234 <RET> -;; -;; The toot, together with its ancestors and descendants, subject to -;; mastodon API depth limit, are displayed in an org buffer. - -;; TODO: -;; -;; To be able to refresh the org buffer at an org entry, which would -;; re-fetch the context of the corresponding toot and upsert them in -;; the buffer. -;;; Code: - - -(require 'hierarchy) -(require 'json) -(require 'url-parse) - -(defvar mastorg-buffer "*mastorg*" "Buffer name for mastorg buffers.") - -;;; Fetching utilities -(defvar mastorg-client-buffer-name "*mastorg-api*" - "Buffer name for logging API requests.") - -(defun mastorg-url-fetch-json (url &optional decompression with-header) - "Fetch and parse json from URL. - -With nonnil DECOMPRESSION, gunzip the response first. -With nonnil WITH-HEADER, include the response headers in the return value." - (mastorg-url-fetch-internal - url - (lambda () - (json-read-from-string (decode-coding-string (buffer-string) 'utf-8))) - decompression - with-header)) - -(defun mastorg-url-fetch-internal (url buffer-processor decompression with-header) - "Fetch from URL and process the response with BUFFER-PROCESSOR. - -With nonnil DECOMPRESSION, gunzip the response first. -With nonnil WITH-HEADER, include the response headers in the return value." - (with-current-buffer (get-buffer-create mastorg-client-buffer-name) - (goto-char (point-max)) - (insert "[" (current-time-string) "] Request: " url "\n")) - (with-current-buffer (url-retrieve-synchronously url t) - (let ((header (mastorg-kill-http-header)) (status) (fields)) - (goto-char (point-min)) - (setq header (mastorg-parse-http-header header) - status (alist-get 'status header) - fields (alist-get 'fields header)) - (with-current-buffer mastorg-client-buffer-name - (insert "[" (current-time-string) "] Response: " status "\n")) - (when decompression - (call-process-region (point) (point-max) "gunzip" t t t) - (goto-char (point-min))) - (call-interactively 'delete-trailing-whitespace) - (if (string= status "200") - (unless (= (point) (point-max)) - (if with-header - (list - (cons 'header fields) - (cons 'json (funcall buffer-processor))) - (funcall buffer-processor))) - (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) - -(defun mastorg-kill-http-header () - "Kill http headers in the current buffer." - (mastorg-skip-http-header) - (let ((killed (buffer-substring-no-properties (point-min) (point)))) - (delete-region (point-min) (point)) - killed)) - -(defun mastorg-skip-http-header () - "Skip http headers in the current buffer." - (goto-char (point-min)) - (re-search-forward "\r?\n\r?\n")) - -(defun mastorg-parse-http-header (text) - "Parse http headers from TEXT in the current buffer." - (let ((status) (fields)) - (with-temp-buffer - (insert text) - (goto-char (point-min)) - (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$") - (setq status (match-string 1)) - (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t) - (push (cons (intern (match-string 1)) (match-string 2)) fields))) - (list (cons 'status status) (cons 'fields fields)))) - -;;; mastodon utilities -(defun mastorg-parse-url (url) - "Parse mastodon post URL." - (pcase-let* ((urlobj (url-generic-parse-url url)) - (`(,path . _) (url-path-and-query urlobj)) - (host (url-host urlobj))) - (cons host (caddr (split-string path "/"))))) - -(defun mastorg-api-status (url) - "Get the status given URL." - (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url))) - (mastorg-url-fetch-json - (format "https://%s/api/v1/statuses/%s" host post-id)))) - -(defun mastorg-api-status-context (url) - "Get the status context given URL." - (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url))) - (mastorg-url-fetch-json - (format "https://%s/api/v1/statuses/%s/context" host post-id)))) - -(defun mastorg-get-first-ancestor (url) - "Given a mastodon URL, return the url of its first ancestor." - (let ((ancestors - (alist-get 'ancestors (mastorg-api-status-context url)))) - (if (length> ancestors 0) - (alist-get 'url (elt ancestors 0)) - url))) - -(defun mastorg-toot-make-parent-fn (toots) - "Given a collection of TOOTS, return a function that find the parent toot." - (lambda (toot) - (let ((id (alist-get 'in_reply_to_id toot))) - (seq-find - (lambda (candidate) - (equal (alist-get 'id candidate) id)) - toots)))) - -;;; Formatting functions -(defun mastorg-format-toot-tree (url) - "Format a toot tree of toot located at URL. - -Including ancestors and descendants, if any." - (let* ((toots-hier (hierarchy-new)) - (context-toots (mastorg-api-status-context url)) - (toots (vconcat - (alist-get 'ancestors context-toots) - (vector (mastorg-api-status url)) - (alist-get 'descendants context-toots)))) - (hierarchy-add-trees - toots-hier - toots - (mastorg-toot-make-parent-fn toots)) - (string-join - (hierarchy-map 'mastorg-format-toot toots-hier 1) - "\n"))) - -(defun mastorg-format-toot (toot level) - "Format a TOOT with indent LEVEL." - (pcase-let* ((url (alist-get 'url toot)) - (account (alist-get 'account toot)) - (display-name (alist-get 'display_name account)) - (username (alist-get 'username account)) - (`(,host . _) (mastorg-parse-url url))) - (format "%s %s @%s@%s %s\n%s" - (make-string level ?*) - (if (string-empty-p display-name) username display-name) - username - host - (alist-get 'created_at toot) - (with-temp-buffer - (insert (alist-get 'content toot)) - (shr-render-region (point-min) (point-max)) - (buffer-substring-no-properties (point-min) (point-max)))))) - -;;;###autoload -(defun mastorg-open (url) - "Given a mastodon toot URL, open an org buffer rendering the toot. - -Including the context, i.e. ancestors and descendant toots." - (interactive "sToot URL: ") - (with-current-buffer (get-buffer-create mastorg-buffer) - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (mastorg-format-toot-tree url)) - (org-mode) - (goto-char (point-min)))) - (switch-to-buffer mastorg-buffer)) - -(provide 'mastorg) -;;; mastorg.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-buffer.el b/emacs/.emacs.d/lisp/my/my-buffer.el index f06956f..a8683de 100644 --- a/emacs/.emacs.d/lisp/my/my-buffer.el +++ b/emacs/.emacs.d/lisp/my/my-buffer.el @@ -239,24 +239,52 @@ that point." (setq buffer temp-buffer)) (set-window-buffer first-window buffer))) +(defun my-set-left-buffer () + "Generate and switch to an empty buffer." + (interactive) + (set-window-buffer + (window-left (get-buffer-window)) + (with-current-buffer (get-buffer-create "*my-left*") + (read-only-mode t) + (current-buffer)))) + +(defun my-set-right-buffer () + "Generate and switch to an empty buffer." + (interactive) + (set-window-buffer + (window-right (get-buffer-window)) + (with-current-buffer (get-buffer-create "*my-right*") + (read-only-mode t) + (current-buffer)))) + (defun my-toggle-focus-write () "Toggle focus write mode. Focus write: make the current window the only one centered with -width 80. If in org-mode, also narrow to current subtree." +width 80. If in org-mode, also narrow to current subtree. Make +buffers on both sides empty read-only buffers." (interactive) - ;; Only one window in the current frame indicates we are in focus - ;; write mode. - (if (length= (window-list) 1) + (if (and (equal + (buffer-name + (window-buffer (window-left (get-buffer-window)))) + "*my-left*") + (equal + (buffer-name + (window-buffer (window-right (get-buffer-window)))) + "*my-right*")) (progn (winner-undo) (when (derived-mode-p 'org-mode) (widen))) (when (derived-mode-p 'org-mode) (org-narrow-to-subtree)) - (delete-other-windows) - (let ((margin (/ (- (window-width) 80) 2))) - (set-window-margins nil margin margin)))) + (my-set-left-buffer) + (my-set-right-buffer) + (let ((margin (/ (- 80 (window-width)) 2))) + (enlarge-window margin t) + (windmove-left) + (enlarge-window (- margin) t) + (windmove-right)))) (defun my-select-new-window-matching-mode (mode) "Select a new window." @@ -415,6 +443,11 @@ for the given MAJOR-MODE, any text is appended to it." (4 (my-buffer-scratch-setup region default-mode)) (_ (my-buffer-scratch-setup region))))) +(defun my-new-empty-buffer () + "Generate and switch to an empty buffer." + (interactive) + (switch-to-buffer (generate-new-buffer "empty"))) + (defcustom my-scratch-buffer-default-mode 'org-mode "Default major mode for `my-buffer-create-scratch'." :type 'symbol @@ -483,5 +516,15 @@ With double prefix arguments, create a new indirect buffer." (revert-buffer t t)) (switch-to-buffer buffer))) +(defun my-fontify-with-mode (text mode) + "Fontify TEXT with MODE." + (with-temp-buffer + (funcall mode) + (insert text) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (with-no-warnings (font-lock-fontify-buffer))) + (buffer-string))) + (provide 'my-buffer) ;;; my-buffer.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-consult-recoll.el b/emacs/.emacs.d/lisp/my/my-consult-recoll.el new file mode 100644 index 0000000..1754ad4 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-consult-recoll.el @@ -0,0 +1,3 @@ +(defun my-consult-recoll-open-in-pdf-tools (filename &optional page) + (find-file filename) + (when page (pdf-view-goto-page page))) diff --git a/emacs/.emacs.d/lisp/my/my-dired.el b/emacs/.emacs.d/lisp/my/my-dired.el index 83607ab..2fdbfa9 100644 --- a/emacs/.emacs.d/lisp/my/my-dired.el +++ b/emacs/.emacs.d/lisp/my/my-dired.el @@ -109,15 +109,24 @@ With a prefix arg, toggle `my-dired-reverse-sorting' instead." "Empty the xdg trash" (interactive) (let* ((xdg-data-dir - (directory-file-name - (expand-file-name "Trash" - (or (getenv "XDG_DATA_HOME") - "~/.local/share")))) - (trash-files-dir (expand-file-name "files" xdg-data-dir)) - (trash-info-dir (expand-file-name "info" xdg-data-dir))) + (directory-file-name + (expand-file-name "Trash" + (or (getenv "XDG_DATA_HOME") + "~/.local/share")))) + (trash-files-dir (expand-file-name "files" xdg-data-dir)) + (trash-info-dir (expand-file-name "info" xdg-data-dir))) (delete-directory trash-files-dir t) (delete-directory trash-info-dir t))) +(defun my-dired-jump-xdg-trash () + "Open the xdg trash dir in dired." + (interactive) + (dired + (directory-file-name + (expand-file-name "Trash" + (or (getenv "XDG_DATA_HOME") + "~/.local/share"))))) + (defun my-dired-do-delete (delete-fun &optional arg) "Wrapper of `dired-do-delete'. diff --git a/emacs/.emacs.d/lisp/my/my-editing.el b/emacs/.emacs.d/lisp/my/my-editing.el index 0775063..e6499ff 100644 --- a/emacs/.emacs.d/lisp/my/my-editing.el +++ b/emacs/.emacs.d/lisp/my/my-editing.el @@ -528,7 +528,7 @@ With an prefix-arg, copy the file name relative to project root." (interactive) (let ((old-max (point-max)) (old-point (point))) - (comment-kill (or n 1)) + (when comment-start (comment-kill (or n 1))) (when (= old-max (point-max)) (goto-char old-point) (kill-sexp n)))) @@ -546,11 +546,32 @@ With an prefix-arg, copy the file name relative to project root." (defun my-elide-region (b e) (interactive "r") - (let ((message-elide-ellipsis (concat comment-start - " [... %l lines elided] -"))) + (let ((message-elide-ellipsis + (if (> 1 (count-lines b (min (1+ e) (point-max)))) + (concat comment-start + " [... %l lines elided] +") + (format " [... %d words elided]" (count-words b e))))) (message-elide-region b e))) +(defun my-elide-text (text limit) + "Elide TEXT to about LIMIT characters." + (let ((keep (- limit 25))) + (when (< keep 0) + (error "Too few characters to limit to. Should be at least 25.")) + (with-temp-buffer + (insert text) + (goto-char (point-min)) + (while (and (<= (point) keep) (< (point) (point-max))) + (forward-word)) + (cond ((> (point) keep) + (backward-word) + (my-elide-region (point) (point-max)) + (buffer-string)) + (t text)) + )) + ) + (defun my-replace-no-filter (old-fun &rest r) (let ((search-invisible t)) (apply old-fun r))) diff --git a/emacs/.emacs.d/lisp/my/my-emms.el b/emacs/.emacs.d/lisp/my/my-emms.el index ffb6bc0..e8be5ee 100644 --- a/emacs/.emacs.d/lisp/my/my-emms.el +++ b/emacs/.emacs.d/lisp/my/my-emms.el @@ -165,7 +165,7 @@ either 'audio or 'video (if (and (length> players 1) (string-prefix-p "file://" name) (member (file-name-extension name) - '("mkv" "mp4" "ogv" "avi" "webm"))) + '("mkv" "ogv" "avi" "webm"))) 'emms-player-vlc 'emms-player-mpv))) @@ -300,10 +300,23 @@ filter extensions from filter-exts." (defvar my-emms-i3bar-file (locate-user-emacs-file "emms-i3bar") "File to write current playing to which i3bar reads") (defun my-emms-get-display-name (track) + "Return the display name of a track. + +The display name is either the info-title, or the display name of +the filename." (or (alist-get 'info-title track) (when-let ((name (alist-get 'name track))) - (replace-regexp-in-string "^\\(.*/\\)\\(.*/.*/.*\\)" "\\2" name)))) + (my-emms-get-display-name-1 name)))) + +(defun my-emms-get-display-name-1 (name) + "Return the display name of a filename NAME. + +The display name is the last three components of the filename, +assuming the filesystem hierarchy is arranged in +artist/album/track." + (replace-regexp-in-string "^\\(.*/\\)\\(.*/.*/.*\\)" "\\2" name)) + (defun my-emms-output-current-track-to-i3bar-file () (let ((current-track (my-emms-get-display-name (emms-playlist-current-selected-track)))) @@ -361,17 +374,20 @@ filter extensions from filter-exts." my-emms-favourites-playlist))) ;;; random album in emms -(defun my-my-emms-current-album-name () +(defun my-emms-current-album-name () (file-name-directory (my-emms-get-current-track-name))) +(defun my-emms-playlist-album-name-at-point () + (file-name-directory (emms-track-get (emms-playlist-track-at) 'name))) + (defun my-emms-next-track-or-random-album () (interactive) - (let ((current-album (my-my-emms-current-album-name))) + (let ((current-album (my-emms-current-album-name))) (when emms-player-playing-p (emms-stop)) (emms-playlist-current-select-next) - (if (string-equal (my-my-emms-current-album-name) current-album) + (if (string-equal (my-emms-current-album-name) current-album) (emms-start) - (my-emms-random-album nil)))) + (my-emms-playlist-random-album)))) (defvar-local my-emms-albums-cache (vector)) @@ -402,20 +418,145 @@ under /zzz-seren/." (elt my-emms-albums-cache (random (length my-emms-albums-cache))))) album)) -(defun my-emms-random-album (update-album) - (interactive "P") +(defun my-emms-playlist-random-album () + (interactive) (with-current-emms-playlist - (when (or update-album (length= my-emms-albums-cache 0)) - (my-emms-save-albums-cache)) - (when emms-player-playing-p (emms-stop)) - (let ((saved-position (point))) - (goto-char (point-min)) - (if (search-forward - (my-emms-get-random-album) - nil t) - (emms-playlist-mode-play-current-track) - (goto-char saved-position) - (error "Cannot play random album"))))) + (goto-line (1+ (random (count-lines (point-min) (point-max))))) + (let ((album-name (my-emms-playlist-album-name-at-point))) + (goto-char (point-min)) + (search-forward album-name) + (beginning-of-line) + (emms-playlist-mode-play-current-track)))) + +(defvar my-emms-playlist-group-length 20 + "Length of a track group in an album.") + +(defvar my-emms-playlist-tail-group-length 10 + "Min length of a tail track group in an album.") + +(defun my-emms-playlist-group-bounds () + "Return (GROUP-START . GROUP-END) of the group the current track belongs to." + (save-excursion + (let* ((album-name (my-emms-playlist-album-name-at-point)) + (current-ln (line-number-at-pos)) + (start-ln (progn (goto-char (point-min)) + (re-search-forward (concat "^" (regexp-quote album-name))) + (line-number-at-pos))) + (end-ln (progn (goto-char (point-max)) + (re-search-backward (concat "^" (regexp-quote album-name))) + (1+ (line-number-at-pos)))) + ;; How many tracks have been from the start of the album + ;; (exclusive) + (past (- current-ln start-ln)) + ;; ;; How many tracks to go (inclusive) + ;; (remain (- end-ln current-ln)) + (idx (/ past my-emms-playlist-group-length)) + (maybe-group-start (+ start-ln (* idx my-emms-playlist-group-length))) + (group-start + (if (< (- end-ln maybe-group-start) my-emms-playlist-tail-group-length) + ;; Too close to the end of the album + (max start-ln (- maybe-group-start my-emms-playlist-group-length)) + maybe-group-start)) + (maybe-group-end (+ group-start my-emms-playlist-group-length)) + (group-end + (if (<= (- end-ln maybe-group-end) my-emms-playlist-tail-group-length) + end-ln + (min end-ln maybe-group-end)))) + (cons group-start group-end)))) + +(defvar-local my-emms-playlist-group-start-overlay nil) +(defvar-local my-emms-playlist-group-end-overlay nil) + +(defun my-emms-playlist-mark-bounds (group-end) + "Mark bounds of the current track group. + +An up arrow at the first played in the current group, and a down +arrow at the end of the track group." + (when my-emms-playlist-group-start-overlay + (delete-overlay my-emms-playlist-group-start-overlay)) + (when my-emms-playlist-group-start-overlay + (delete-overlay my-emms-playlist-group-end-overlay)) + (setq my-emms-playlist-group-start-overlay (make-overlay (point) (point))) + (overlay-put + my-emms-playlist-group-start-overlay + 'before-string (propertize + "x" 'display + `(left-fringe up-arrow emms-playlist-selected-face))) + (save-excursion + (goto-line (1- group-end)) + (setq my-emms-playlist-group-end-overlay (make-overlay (point) (point))) + (overlay-put + my-emms-playlist-group-end-overlay + 'before-string (propertize + "x" 'display + `(left-fringe down-arrow emms-playlist-selected-face))))) + +(defun my-emms-mode-line-playlist-current () + "Format the currently playing song. + +Override `emms-mode-line-playlist-current' to incorporate wide chars." + (let ((track-desc (my-emms-get-display-name-1 + (emms-track-description + (emms-playlist-current-selected-track))))) + (format emms-mode-line-format + (if (< (string-width track-desc) emms-mode-line-length-limit) + track-desc + (concat + (seq-subseq + track-desc 0 + (- (length track-desc) + (- (string-width track-desc) emms-mode-line-length-limit))) + "..."))))) + + +;; (defun my-emms-playing-time-mode-line () +;; "Add playing time to the mode line. + +;; Override `emms-playing-time-mode-line': prepend instead of append." +;; (or global-mode-string (setq global-mode-string '(""))) +;; (unless (member 'emms-playing-time-string +;; global-mode-string) +;; (setq global-mode-string +;; (append '(emms-playing-time-string) global-mode-string)))) + + +(defun my-emms-playlist-random-group () + (interactive) + (with-current-emms-playlist + (let ((random-line (1+ (random (count-lines (point-min) (point-max)))))) + (goto-line random-line) + (pcase-let ((`(,group-start . ,group-end) (my-emms-playlist-group-bounds))) + (message "my-emms-playlist-random-group: (%d, %d)" random-line group-start) + (goto-line group-start) + (my-emms-playlist-mark-bounds group-end) + (emms-playlist-mode-play-current-track))))) + +;;; TODO: mark bounds if and only if the currently played is out of +;;; the existing overlay. +(defun my-emms-playlist-maybe-mark-bounds () + "Used as an `emms-player-started-hook'. + +If the last command is `emms-playlist-mode-play-smart' i.e. the +user manually chose the track to play, and if +`emms-player-next-function' is +`my-emms-next-track-or-random-group', then mark boundaries since +it would not have been marked otherwise." + (when (and (eq last-command 'emms-playlist-mode-play-smart) + (eq emms-player-next-function 'my-emms-next-track-or-random-group)) + (with-current-emms-playlist + (pcase-let ((`(_ . ,group-end) (my-emms-playlist-group-bounds))) + (my-emms-playlist-mark-bounds group-end))))) + +(defun my-emms-next-track-or-random-group () + (interactive) + (with-current-buffer emms-playlist-buffer + (emms-playlist-mode-center-current) + (pcase-let ((`(,group-start . ,group-end) (my-emms-playlist-group-bounds))) + (when emms-player-playing-p (emms-stop)) + (if (>= (1+ (line-number-at-pos)) group-end) + (my-emms-playlist-random-group) + (emms-playlist-current-select-next) + (emms-start))))) ;;; override the minor mode ;;;###autoload @@ -473,13 +614,79 @@ Hex-encoded characters in URLs are replaced by the decoded character." (let ((type (emms-track-type track))) (cond ((emms-track-get track 'description) - (emms-track-get track 'description)) - ((eq 'file type) - (emms-track-name track)) + (emms-track-get track 'description)) + ((eq 'file type) + (emms-track-name track)) ((eq 'url type) (emms-format-url-track-name (emms-track-name track))) (t (concat (symbol-name type) ": " (emms-track-name track)))))) +(defvar my-emms-score-delta 1) + +(defun my-emms-score-up-playing () + "Increase score by `my-emms-score-delta', then reset the score delta to 1." + (emms-score-change-score + my-emms-score-delta + (my-emms-get-display-name-1 (emms-score-current-selected-track-filename))) + (setq my-emms-score-delta 1)) + +(defun my-emms-score-show-playing () + "Show score for current playing track in minibuf. + +Override `emms-score-show-playing' - using last three components in the name..." + (interactive) + (message "track/tolerance score: %d/%d" + (emms-score-get-score (my-emms-get-display-name-1 + (emms-score-current-selected-track-filename))) + emms-score-min-score)) + +(defun my-emms-score-up-chosen-bonus () + "Bonus score up if the track is started intentionally. + +If the last command is `emms-playlist-mode-play-smart', then set +`my-emms-score-delta' to 2." + (if (not (eq last-command 'emms-playlist-mode-play-smart)) + (setq my-emms-score-delta 1) + (setq my-emms-score-delta 2) + (setq last-command nil)) + ) + +(defun my-emms-wrapped () + "Print top 10 scored tracks." + (interactive) + (let (keys) + (maphash (lambda (k _) (push k keys)) emms-score-hash) + (sort keys (lambda (k1 k2) + (> (cl-second (gethash k1 emms-score-hash)) + (cl-second (gethash k2 emms-score-hash))))) + (message "Top 10: %s" (string-join (take 10 keys) "\n")))) + +(defun my-emms-maybe-get-duration-for-current-track () + "Get duration for the current track. + +Can be used as a `emms-player-started-hook'" + (unless (emms-track-get (emms-playlist-current-selected-track) + 'info-playing-time) + (my-emms-info-ffprobe (emms-playlist-current-selected-track)))) + +(defun my-emms-info-ffprobe (track) + "Use ffprobe for urls to get duration. + +Call + +ffprobe -v error -show_entries format=duration -of default=noprint_wrappers=1:nokey=1 + +on the url" + (when (eq (emms-track-type track) 'url) + (with-temp-buffer + (call-process "ffprobe" nil t nil "-v" "error" "-show_entries" + "format=duration" "-of" "default=noprint_wrappers=1:nokey=1" + (emms-track-name track)) + (let ((duration (string-trim (buffer-string)))) + (when (string-match-p "[0-9.]+" duration) + (emms-track-set track 'info-playing-time + (floor (string-to-number duration)))))))) + (provide 'my-emms) ;;; my-emms.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-epub.el b/emacs/.emacs.d/lisp/my/my-epub.el new file mode 100644 index 0000000..4a3dfca --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-epub.el @@ -0,0 +1,75 @@ +;;; my-epub.el -- epub utils -*- lexical-binding: t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "30.1")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; epub utils. + +;;; Code: + + +(defun my-epub-content-file-name (file-name) + (with-temp-buffer + (if (eq 0 (call-process "unzip" nil t nil + "-p" file-name "META-INF/container.xml")) + (let ((dom (libxml-parse-xml-region (point-min) (point-max)))) + (dom-attr + (dom-by-tag + (dom-by-tag (dom-by-tag dom 'container) 'rootfiles) + 'rootfile) + 'full-path)) + (message "Failed to extract container.xml: %s" (buffer-string)) + nil))) + +(defun my-epub-metadata (file-name) + "Get metadata of an epub file." + (when-let ((content-file-name (my-epub-content-file-name file-name))) + (with-temp-buffer + (call-process "unzip" nil t nil "-p" file-name content-file-name) + (let* ((dom (libxml-parse-xml-region (point-min) (point-max))) + (metadata (dom-by-tag dom 'metadata)) + (title (dom-text (dom-by-tag metadata 'title))) + (authors (dom-texts (dom-by-tag metadata 'creator) ", ")) + (identifier + (replace-regexp-in-string + "[^0-9,]" "" + (dom-texts + (seq-filter + (lambda (node) + (or (equal "ISBN" (dom-attr node 'scheme)) + (string-match-p "^[0-9]+$" (dom-text node)))) + (dom-by-tag metadata 'identifier)) + ","))) + (date (replace-regexp-in-string + "[^0-9]" "" + (dom-text (dom-by-tag metadata 'date)))) + (year (substring date 0 (min 4 (length date))))) + `((title . ,title) + (authors . ,authors) + (year . ,year) + (identifier . ,identifier)) + ;; (pp metadata) + )) + )) + +(provide 'my-epub) +;;; my-epub.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-github.el b/emacs/.emacs.d/lisp/my/my-github.el index 45adcf6..e2d5f6a 100644 --- a/emacs/.emacs.d/lisp/my/my-github.el +++ b/emacs/.emacs.d/lisp/my/my-github.el @@ -25,7 +25,7 @@ ;; Github client. ;;; Code: - +(require 'my-web) (defun my-grok-github (url) "get github info of a project. @@ -54,6 +54,60 @@ License; name; description; homepage; created at" (cons "Developers" (my-grok-github-get-developer-name (alist-get 'url (alist-get 'owner raw)))))) +(defun my-github-api-repos (url) + (when-let* ((urlobj (url-generic-parse-url url)) + (path (url-filename urlobj)) + (project-id + (when (string-match "^/[^/]+/[^/]+" path) + (match-string 0 path)))) + (my-url-fetch-json + (format "https://api.github.com/repos%s" project-id)))) + +(defun my-github-api-readme (url) + (when-let* ((urlobj (url-generic-parse-url url)) + (path (url-filename urlobj)) + (project-id + (when (string-match "^/[^/]+/[^/]+" path) + (match-string 0 path))) + ;; so that the response of readme is in html format + (url-request-extra-headers + '(("Accept" . "application/vnd.github.html")))) + (my-url-fetch-raw + (format "https://api.github.com/repos%s/readme" project-id)))) + +(defun my-github-project-url-p (url) + (let ((urlobj (url-generic-parse-url url))) + (string-match-p "\\(www\\.\\)?github.com" (url-host urlobj)))) + +(defun my-github-project-infobox (url) + (interactive "sGithub repo url: ") + (let ((info + (append + (my-github-api-repos url) + `((readme . ,(my-github-api-readme url)))))) + (infobox-render + (infobox-translate + info my-github-project-info-specs) + `(my-github-project-infobox ,url) + (called-interactively-p 'interactive))) + ) + +(defvar my-github-project-info-specs + `((html_url . ("URL" . my-forge-infobox-format-url)) + (full_name . "Name") + (description . "Description") + (created_at . ("Created at" . my-gitlab-format-time-string)) + (pushed_at . ("Pushed at" . my-gitlab-format-time-string)) + (topics . ("Topics" . ,(lambda (xs) + (mapconcat #'identity xs "; ")))) + (stargazers_count . ("Stars" . number-to-string)) + (forks_count . ("Forks" . number-to-string)) + (readme . (body . ,(lambda (text) + (with-temp-buffer + (insert text) + (shr-render-region (point-min) (point-max)) + (buffer-string))))))) + (defun my-grok-github-get-developer-name (url) (with-current-buffer (url-retrieve-synchronously url) (set-buffer-multibyte t) diff --git a/emacs/.emacs.d/lisp/my/my-gitlab.el b/emacs/.emacs.d/lisp/my/my-gitlab.el index 6dd484c..56542c0 100644 --- a/emacs/.emacs.d/lisp/my/my-gitlab.el +++ b/emacs/.emacs.d/lisp/my/my-gitlab.el @@ -26,8 +26,9 @@ ;;; Code: +(require 'infobox) -(defun my-get-gitlab-project-id (url) +(defun my-gitlab-get-project-id (url) (with-current-buffer (url-retrieve-synchronously (replace-regexp-in-string "\\.git$" "" url)) (let ((dom (libxml-parse-html-region (point-min) (point-max)))) @@ -35,16 +36,77 @@ (dom-search dom (lambda (n) (dom-attr n 'data-project-id)))) 'data-project-id)))) -(defun my-grok-gitlab (url) +(defun my-gitlab-api-projects (url) (when-let* ((urlobj (url-generic-parse-url url)) - (project-id (my-get-gitlab-project-id url))) - (with-current-buffer - (url-retrieve-synchronously - (concat (url-type urlobj) "://" (url-host urlobj) - "/api/v4/projects/" project-id)) - (set-buffer-multibyte t) - (my-delete-http-header) - (my-grok-gitlab-make-info (json-read))))) + (project-id (my-gitlab-get-project-id url))) + (my-url-fetch-json + (format "%s://%s/api/v4/projects/%s" + (url-type urlobj) + (url-host urlobj) + project-id)))) + +(defvar my-gitlab-readme-get-raw nil "Whether to get raw or html readme") + +(defun my-gitlab-project-info (url) + "Given a url, returns project info." + (let ((info (my-gitlab-api-projects url))) + (let-alist info + (when .readme_url + (setf (alist-get 'readme info) + (if my-gitlab-readme-get-raw + (format + "\n%s" + (my-url-fetch-raw + (replace-regexp-in-string "/-/blob/" "/-/raw/" .readme_url))) + (alist-get + 'html + (my-url-fetch-json + (format "%s?format=json&viewer=rich" .readme_url))))))) + info)) + +(defun my-gitlab-format-time-string (t) + (format-time-string "%Y-%m-%d %M:%M:%S" (encode-time (parse-time-string t)))) + +(defun my-gitlab-project-url-p (url) + (let ((urlobj (url-generic-parse-url url))) + (and (equal (url-host urlobj) "gitlab.com") + (string-match-p "^/[^/]+/[^/]+$" (url-filename urlobj))))) + +(require 'my-buffer) +(require 'my-web) +(require 'my-magit) + +(defvar my-gitlab-project-info-specs + `((http_url_to_repo . ("URL" . my-forge-infobox-format-url)) + (name_with_namespace . "Name") + (description . "Description") + (created_at . ("Created at" . my-gitlab-format-time-string)) + (last_activity_at . ("Updated at" . my-gitlab-format-time-string)) + (topics . ("Topics" . ,(lambda (xs) + (mapconcat #'identity xs "; ")))) + (star_count . ("Stars" . number-to-string)) + (forks_count . ("Forks" . number-to-string)) + (readme . (body . ,(lambda (text) + (with-temp-buffer + (insert text) + (shr-render-region (point-min) (point-max)) + (buffer-string))))))) + +(defun my-gitlab-project-infobox (url) + "Display a gitlab project info at URL in a help buffer. + +A good example would be +<https://gitlab.com/woob/woob> +" + (interactive "sGitlab project URL: ") + (infobox-render + (infobox-translate + (my-gitlab-project-info url) my-gitlab-project-info-specs) + `(my-gitlab-project-infobox ,url) + (called-interactively-p 'interactive))) + +(defun my-grok-gitlab (url) + (my-grok-gitlab-make-info (my-gitlab-api-projects url))) (defun my-grok-gitlab-make-info (raw) (list (cons "Title" (alist-get 'name raw)) diff --git a/emacs/.emacs.d/lisp/my/my-gnus.el b/emacs/.emacs.d/lisp/my/my-gnus.el index 14dff82..6a2142b 100644 --- a/emacs/.emacs.d/lisp/my/my-gnus.el +++ b/emacs/.emacs.d/lisp/my/my-gnus.el @@ -162,7 +162,7 @@ The archiving target comes from `my-gnus-group-alist'." "The default inbox to be opened with `my-gnus-open-inbox'.") (defun my-gnus-open-inbox () (interactive) - (gnus-group-read-group t t my-gnus-inbox-group)) + (gnus-group-read-group 200 t my-gnus-inbox-group)) (defun my-gnus-start () (interactive) diff --git a/emacs/.emacs.d/lisp/my/my-ledger.el b/emacs/.emacs.d/lisp/my/my-ledger.el new file mode 100644 index 0000000..b1ad2ca --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-ledger.el @@ -0,0 +1,52 @@ +;;; my-ledger.el -- customizations to ledger mode -*- lexical-binding: t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "29.4")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; customizations to ledger mode. + +;;; Code: + + +(defun my-ledger-move-xact-down () + (interactive) + (call-interactively 'transpose-paragraphs) + (call-interactively 'ledger-navigate-prev-xact-or-directive)) + +(defun my-ledger-move-xact-up () + (interactive) + (call-interactively 'ledger-navigate-prev-xact-or-directive) + (call-interactively 'transpose-paragraphs) + (call-interactively 'ledger-navigate-prev-xact-or-directive) + (call-interactively 'ledger-navigate-prev-xact-or-directive)) + +;;; hledger: Error: /home/ycp/Documents/finance/huecu.ledger:1615:41: +(defvar my-ledger-compilation-error-re + '(ledger "^hledger: Error: \\(.+\\):\\([0-9]+\\):\\([0-9]+\\):$" 1 2 3)) + +(defun my-ledger-set-compile-command () + (setq-local + compile-command + (format "%s bal -f %s" ledger-binary-path buffer-file-name))) + +(provide 'my-ledger) +;;; my-ledger.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-libgen.el b/emacs/.emacs.d/lisp/my/my-libgen.el index 6b65eb1..d4efb30 100644 --- a/emacs/.emacs.d/lisp/my/my-libgen.el +++ b/emacs/.emacs.d/lisp/my/my-libgen.el @@ -42,6 +42,8 @@ (defvar my-libgen-host nil) (defvar my-libgen-library-host nil) +(defvar my-libgen-plus-host nil) + (defun my-libgen-set-random-hosts () "Randomly set `my-libgen-host' and `my-libgen-library-host'" (setq my-libgen-library-host @@ -134,7 +136,7 @@ (alist-get 'coverurl info))))) (defun my-libgen-format-filename (info) - (replace-regexp-in-string "[:;]" "_" + (replace-regexp-in-string "[:;?/]" "_" (format "%s - %s (%s) [%s].%s" (alist-get 'author info) @@ -160,7 +162,68 @@ id-head (downcase (alist-get 'md5 info))))) -(defun my-libgen-download-action () +(defun my-libgen-plus-get-download-url (info) + (let-alist info + (file-name-concat + my-libgen-plus-host + (dom-attr + (dom-search + (my-url-fetch-dom (format "%s/ads.php?md5=%s" my-libgen-plus-host .md5)) + (lambda (n) + (string-match (format "get\\.php\\?md5=%s" .md5) + (or (dom-attr n 'href) "")))) + 'href)))) + +(defun my-libgen-plus-download-action () + (interactive) + (let* ((info (get-text-property (point) 'button-data)) + (filename (file-name-concat (expand-file-name my-libgen-download-dir) + (my-libgen-format-filename info))) + (md5 (alist-get 'md5 info))) + (my-wget-async + (my-libgen-plus-get-download-url info) + filename + nil + (lambda () (my-libgen-check-md5 filename md5))))) + +(defun my-libgen-plus-edition-infobox (edition-id) + (let ((dom (my-url-fetch-dom + (format "%s/edition.php?id=%s" my-libgen-plus-host edition-id)))) + (infobox-render-string + (with-temp-buffer + (insert (mapconcat (lambda (p) (dom-texts p "")) + (dom-by-tag (dom-by-class dom "order-2") 'p) "\n")) + (shr-insert-document (dom-by-class dom "order-5")) + (buffer-string)) + `(my-libgen-plus-edition-infobox ,edition-id) + (called-interactively-p 'interactive) + ) + )) + +(defun my-libgen-plus-infobox-action () + (interactive) + (my-libgen-plus-edition-infobox + (alist-get 'edition-id (get-text-property (point) 'button-data)))) + +(defun my-libgen-check-md5 (file md5) + (let ((actual (substring (my-call-process-out "md5sum" file) 0 32))) + (unless (equal actual md5) + (warn "MD5 checksum of %s mismatch: should be %s but actually %s" + file md5 actual)))) + +(defun my-libgen-download-library-action () + (interactive) + (let* ((info (get-text-property (point) 'button-data)) + (filename (file-name-concat (expand-file-name my-libgen-download-dir) + (my-libgen-format-filename info))) + (md5 (alist-get 'md5 info))) + (my-wget-async + (my-libgen-make-download-link-library info) + filename + nil + (lambda () (my-libgen-check-md5 filename md5))))) + +(defun my-libgen-download-onion-action () (interactive) (let ((info (get-text-property (point) 'button-data))) (my-wget-async @@ -171,18 +234,28 @@ (defvar my-libgen-button-keymap (let ((kmap (make-sparse-keymap))) (set-keymap-parent kmap button-map) - (define-key kmap "d" 'my-libgen-download-action) + (define-key kmap "d" 'my-libgen-download-library-action) + (define-key kmap "t" 'my-libgen-download-onion-action) (define-key kmap "p" 'my-libgen-show-more-info) kmap)) +(defvar my-libgen-plus-button-keymap + (let ((kmap (make-sparse-keymap))) + (set-keymap-parent kmap button-map) + (define-key kmap "d" 'my-libgen-plus-download-action) + (define-key kmap "i" 'my-libgen-plus-infobox-action) + ;; (define-key kmap "t" 'my-libgen-download-onion-action) + ;; (define-key kmap "p" 'my-libgen-show-more-info) + kmap)) + (defun my-libgen-show-more-info () (interactive) (pp (my-grok-libgen-make-info - (elt - (my-libgen-api-by-id - (alist-get 'id - (get-text-property (point) 'button-data))) - 0)))) + (elt + (my-libgen-api-by-id + (alist-get 'id + (get-text-property (point) 'button-data))) + 0)))) (defun my-libgen-search-isbn (isbn) (interactive "sISBN: ") @@ -208,6 +281,34 @@ (default-action . my-grok-libgen-action) (keymap . ,my-libgen-button-keymap)))) +(defun my-libgen-plus-search (query) + (interactive "sQuery: ") + (let* ((dom + (my-url-fetch-dom + (format "%s/index.php?req=%s&topics[]=l&topics[]=c&topics[]=f" + my-libgen-plus-host query))) + (rows + (dom-by-tag + (dom-by-tag + (dom-by-id (dom-by-tag dom 'body) "tablelibgen") 'tbody) + 'tr) + )) + (generic-search-open + (seq-map 'my-libgen-plus-search-parse-tr rows) + (format "libgen-plus-query:%s" query) + `((formatter . my-libgen-plus-search-format-result) + (keymap . ,my-libgen-plus-button-keymap)))) + ) + +(defun my-libgen-plus-search-format-result (info) + (format + "%s [%spp,%s,%s] %s" + (my-libgen-format-filename info) + (alist-get 'pages info) + (alist-get 'publisher info) + (alist-get 'language info) + (alist-get 'filesize-human info))) + (defun my-libgen-search-format-result (info) (format "%s [%s,%spp,%s,%s] %s" @@ -218,6 +319,72 @@ (alist-get 'language info) (alist-get 'filesize-human info))) +(defun my-libgen-plus-parse-title-id (dom) + (let ((as + (dom-by-tag dom 'a)) + (title "") + identifier + edition-id) + (when as + (while (and as (string-empty-p title)) + (setq title (string-trim (dom-texts (car as) "")) + edition-id (string-remove-prefix + "edition.php?id=" + (dom-attr (car as) 'href)) + as (cdr as))) + (when (string-empty-p title) + (error "Title is empty: %s" dom)) + (when as + (setq identifier + (replace-regexp-in-string + "; " "," + (string-trim (dom-texts (dom-by-tag (car as) 'i)))))) + `((title . ,title) + (edition-id . ,edition-id) + (identifier . ,identifier))))) + +(defun my-libgen-plus-guess-md5 (mirrors) + (let ((joined + (string-join mirrors " "))) + (when (string-match "\\<[0-9a-f]\\{32\\}\\>" joined) + (match-string 0 joined)))) + +(defun my-libgen-plus-search-parse-tr (tr) + (let* ((tds (dom-by-tag tr 'td)) + (title-id (my-libgen-plus-parse-title-id (elt tds 0))) + (title (alist-get 'title title-id)) + ;; file-id + (edition-id (alist-get 'edition-id title-id)) + (identifier (alist-get 'identifier title-id)) + (author (string-trim (dom-text (elt tds 1)))) + (publisher (dom-text (elt tds 2))) + (year (dom-texts (elt tds 3))) + (language (dom-text (elt tds 4))) + (pages (dom-text (elt tds 5))) + (size-id (car (dom-by-tag (elt tds 6) 'a))) + (filesize-human (dom-text size-id)) + (file-id (string-remove-prefix "/file.php?id=" + (dom-attr size-id 'href))) + (extension (dom-text (elt tds 7))) + (mirrors-td (elt tds 8)) + (mirrors (seq-map (lambda (mirror) (dom-attr mirror 'href)) + (dom-by-tag mirrors-td 'a))) + (md5 (when mirrors (my-libgen-plus-guess-md5 mirrors))) + ) + `((title . ,title) + (identifier . ,identifier) + (edition-id . ,edition-id) + (author . ,author) + (publisher . ,publisher) + (language . ,language) + (year . ,year) + (pages . ,pages) + (filesize-human . ,filesize-human) + (file-id . ,file-id) + (extension . ,extension) + (mirrors . ,mirrors) + (md5 . ,md5)))) + (defun my-libgen-search-parse-tr (tr) (let* ((tds (dom-by-tag tr 'td)) (id (dom-text (pop tds))) @@ -251,5 +418,121 @@ (filesize-human . ,filesize-human) (extension . ,extension)))) +(defvar my-libfic-download-dir "~/Downloads") +(defun my-libfic-search (query) + (interactive "sQuery: ") + (generic-search-open + (mapcar 'my-libfic-search-parse-tr + (cdr + (dom-by-tag + (my-url-fetch-dom + (format "%s/fiction/?q=%s" + my-libgen-host query)) + 'tr))) + (format "libfic-query:%s" query) + `((formatter . my-libfic-search-format-result) + (default-action . my-grok-libfic-action) + (keymap . ,my-libfic-button-keymap)))) + +(defun my-libfic-search-parse-tr (tr) + (let* ((tds (dom-by-tag tr 'td)) + (author (string-trim (dom-texts (pop tds) ""))) + (series (dom-text (pop tds))) + (title-id (pop tds)) + (title-md5 (car (dom-by-tag title-id 'a))) + (title (dom-text title-md5)) + (md5 (elt (split-string (or (dom-attr title-md5 'href) "") "/") 2)) + (identifier (dom-text (dom-by-class title-id "catalog_identifier"))) + (language (dom-text (pop tds))) + (extension-filesize-human (split-string (dom-text (pop tds)) " / ")) + (extension (downcase (car extension-filesize-human))) + (filesize-human (cadr extension-filesize-human)) + ) + `((author . ,author) + (series . ,series) + (md5 . ,md5) + (title . ,title) + (identifier . ,identifier) + (language . ,language) + (filesize-human . ,filesize-human) + (extension . ,extension)))) + +(defun my-libfic-search-format-result (info) + (format + "%s [%s] %s" + (my-libfic-format-filename info) + (alist-get 'language info) + (alist-get 'filesize-human info))) + +(defun my-libfic-format-filename (info) + (replace-regexp-in-string "[:;]" "_" + (format + "%s - %s (%s) [%s].%s" + (alist-get 'author info) + (alist-get 'title info) + (alist-get 'series info) + (alist-get 'identifier info) + (alist-get 'extension info)))) + +(defun my-grok-libfic-action (info) + (interactive) + (my-org-create-node + (my-grok-libfic-make-info + (my-libfic-update-info info)) + t)) + +(defun my-libfic-update-info (info) + (when-let ((tr-id + (seq-find + (lambda (tr) + (equal "ID:" (dom-text (car (dom-by-tag tr 'td))))) + (dom-by-tag + (my-url-fetch-dom + (format "%s/fiction/%s" my-libgen-host (alist-get 'md5 info))) + 'tr)))) + `((id . ,(dom-text (cadr (dom-by-tag tr-id 'td)))) . ,info))) + +;;; todo: description; publisher; cover +(defun my-grok-libfic-make-info (info) + (list + (cons "libfic-id" (alist-get 'id info)) + (cons "Title" (alist-get 'title info)) + (cons "Series" (alist-get 'series info)) + (cons "Authors" (alist-get 'author info)) + (cons "ISBN" (alist-get 'identifier info)) + (cons "Language" (alist-get 'language info)) + (cons "Filesize-human" (alist-get 'filesize-human info)) + (cons "Extension" (alist-get 'extension info)) + (cons "md5" (alist-get 'md5 info)))) + +(defvar my-libfic-button-keymap + (let ((kmap (make-sparse-keymap))) + (set-keymap-parent kmap button-map) + (define-key kmap "d" 'my-libfic-download-action) + (define-key kmap "p" 'my-libfic-show-more-info) + kmap)) + +(defun my-libfic-show-more-info () + (interactive) + (let ((info (get-text-property (point) 'button-data))) + (pp (my-grok-libfic-make-info (my-libfic-update-info info))))) + +(defun my-libfic-download-action () + (interactive) + (let ((info (get-text-property (point) 'button-data))) + (my-wget-async + (my-libfic-make-download-link-onion + (my-libfic-update-info info)) + (format "%s/%s" (expand-file-name my-libfic-download-dir) + (my-libfic-format-filename info))))) + +(defun my-libfic-make-download-link-onion (info) + (let ((id-head (substring (alist-get 'id info) 0 -3))) + (format "%s/FF/%s%s/%s" + my-libgen-onion-host + (make-string (- 4 (length id-head)) ?0) + id-head + (downcase (alist-get 'md5 info))))) + (provide 'my-libgen) ;;; my-libgen.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-magit.el b/emacs/.emacs.d/lisp/my/my-magit.el index efb3c84..eabed05 100644 --- a/emacs/.emacs.d/lisp/my/my-magit.el +++ b/emacs/.emacs.d/lisp/my/my-magit.el @@ -32,23 +32,26 @@ (require 'my-project) (require 'org) -(defun my-magit-clone-org-source (arg) - (interactive "P") - (let* ((url (or (org-entry-get (point) "Source") - (org-entry-get (point) "Website"))) - (default-base-dir - (alist-get "3p" my-projects-root-dirs nil nil 'string=)) +(defun my-magit-clone (url prefix-arg) + (let* ((default-base-dir + (alist-get "3p" my-projects-root-dirs nil nil 'string=)) (default-name - (progn (string-match "^.*/\\(.*?\\)\\(\\.git\\)?$" url) - (match-string 1 url))) + (progn (string-match "^.*/\\(.*?\\)\\(\\.git\\)?$" url) + (match-string 1 url))) (dir (read-file-name - (if arg "Clone to: " "Shallow clone to: ") + (if prefix-arg "Clone to: " "Shallow clone to: ") (concat default-base-dir "/") nil nil default-name))) - (if arg + (if prefix-arg (magit-clone-regular url dir nil) - (magit-clone-shallow url dir nil 1)) + (magit-clone-shallow url dir nil 1)))) + +(defun my-magit-clone-org-source (arg) + (interactive "P") + (let* ((url (or (org-entry-get (point) "Source") + (org-entry-get (point) "Website")))) + (my-magit-clone url arg) (org-set-property "Local-source" (format "<file:%s>" dir)))) diff --git a/emacs/.emacs.d/lisp/my/my-mariadb.el b/emacs/.emacs.d/lisp/my/my-mariadb.el index 6b0e06b..d6c2463 100644 --- a/emacs/.emacs.d/lisp/my/my-mariadb.el +++ b/emacs/.emacs.d/lisp/my/my-mariadb.el @@ -33,7 +33,9 @@ (interactive) (if (equal (file-name-extension (buffer-file-name)) "test") - (call-interactively 'project-compile) + (progn + (my-mtr-set-compile-command) + (call-interactively 'compile)) (sql-send-buffer))) (defun my-gdb-maria () @@ -251,6 +253,24 @@ enum spider_malloc_id { nil t) (tempel-insert 'ps))) +(defun my-mariadb-kb-url-p (url) + (string-match-p "https://mariadb.com/kb/en/\\([^/]+\\)/" url)) + +(defun my-wiki-mariadb-extract-kb-source () + "Extract the kb source from the current buffer. + +Used for wiki mode as a post-processor." + (let ((source + (dom-text + (dom-by-id + (libxml-parse-html-region (point-min) (point-max)) + "answer_source")))) + (erase-buffer) + (insert source)) + (goto-char (point-min)) + (save-buffer) + ) + (defun my-mariadb-fetch-kb-source (url) "Fetches the source to an maridb kb entry at URL. @@ -270,5 +290,34 @@ switches to the buffer." (file-name (format "/tmp/%s.wiki" term))) (my-save-text-and-switch-to-buffer source file-name))) +(defvar my-mtr-compilation-error-re + '(mtr "^mysqltest: At line \\([0-9]+\\)" nil 1)) + +;; (defun my-mtr-find-test-file (test-name &optional dir) +;; (unless dir (setq dir default-directory)) +;; ()) + +(defun my-mtr-set-compile-command () + (when (and buffer-file-name + (equal "test" (file-name-extension buffer-file-name))) + (when-let* + ((source-dir (expand-file-name (project-root (project-current)))) + (build-dir (replace-regexp-in-string "/src/$" "/build/" source-dir)) + (test-name + (progn + (when (string-match + "^.*/mysql-test/\\(.+?\\)/\\(t/\\)?\\([^/]+\\)\\.test$" + buffer-file-name) + (format "%s.%s" + (match-string 1 buffer-file-name) + (match-string 3 buffer-file-name)))))) + (setq-local + compile-command + (format "%s %s %s %s" + "taskset -c 0-3" + (file-name-concat build-dir "mysql-test/mtr") + test-name + "--rr"))))) + (provide 'my-mariadb) ;;; my-mariadb.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-net.el b/emacs/.emacs.d/lisp/my/my-net.el index 1f1cbc6..b19ce68 100644 --- a/emacs/.emacs.d/lisp/my/my-net.el +++ b/emacs/.emacs.d/lisp/my/my-net.el @@ -29,12 +29,24 @@ ;;; net utilities (defvar my-download-dir "~/Downloads") +(defvar my-webpage-download-dir "~/Downloads") -(defun my-make-file-name-from-url (url) - (file-name-nondirectory - (directory-file-name - (car (url-path-and-query (url-generic-parse-url - (url-unhex-string url))))))) +(defmacro my-url-as-googlebot (&rest body) + "Run BODY while spoofing as googlebot" + `(let ((url-request-extra-headers '(("X-Forwarded-For" . "66.249.66.1"))) + (url-user-agent + "Mozilla/5.0 (compatible; Googlebot/2.1; +http://www.google.com/bot.html)")) + ,@body)) + +(def-edebug-spec my-url-as-googlebot t) + +(defun my-make-file-name-from-url (url &optional extension) + (format "%s%s" + (file-name-nondirectory + (directory-file-name + (car (url-path-and-query (url-generic-parse-url + (url-unhex-string url)))))) + (if extension (concat "." extension) ""))) ;; stolen from `eww-make-unique-file-name' (defun my-make-unique-file-name (file directory) @@ -119,6 +131,14 @@ It checks the STATUS, and if it is ok, saves the payload to FILE-NAME." decompression with-header)) + +(defun my-url-fetch-raw (url &optional decompression with-header) + (my-url-fetch-internal + url + (lambda () (decode-coding-string (buffer-string) 'utf-8)) + decompression + with-header)) + (defun my-url-fetch-internal (url buffer-processor decompression with-header) (with-current-buffer (get-buffer-create my-client-buffer-name) (goto-char (point-max)) @@ -141,7 +161,7 @@ It checks the STATUS, and if it is ok, saves the payload to FILE-NAME." (list (cons 'header fields) (cons 'json (funcall buffer-processor))) - (funcall buffer-processor))) + (when buffer-processor (funcall buffer-processor)))) (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) (provide 'my-net) diff --git a/emacs/.emacs.d/lisp/my/my-nov.el b/emacs/.emacs.d/lisp/my/my-nov.el index 863d09a..d43a8f3 100644 --- a/emacs/.emacs.d/lisp/my/my-nov.el +++ b/emacs/.emacs.d/lisp/my/my-nov.el @@ -41,10 +41,26 @@ chapter title." ;; this shouldn't happen for properly authored EPUBs (when (not title) (setq title "No title")) + ;; TODO: fix mode line update (setq mode-line-buffer-identification - (concat title ": " chapter-title)) + (format "%s: %s (%d%%)" + title chapter-title + (/ (* 100 (my-nov-word-position)) my-nov-total-word-count) + )) )) +(defun my-nov-render-span (dom) + (unless (equal (dom-attr dom 'epub:type) "pagebreak") + (shr-generic dom))) + +(defun my-nov-find-file-with-ipath (file-name ipath) + "Find epub file and goto IPATH. + +Useful for recoll." + (find-file file-name) + (unless (derived-mode-p 'nov-mode) (nov-mode)) + (nov-goto-document (nov-find-document (lambda (p) (eq ipath (car p)))))) + (defun my-nov-scroll-up (arg) "Scroll with `scroll-up' or visit next chapter if at bottom." (interactive "P") @@ -52,5 +68,125 @@ chapter title." (nov-next-document) (follow-scroll-up arg))) +(defun my-nov-copy-buffer-file-with-staging () + (interactive) + (unless (derived-mode-p 'nov-mode) (error "Not in nov mode")) + (pcase-let* ((name + (completing-read (format "Copy %s to: " nov-file-name) + my-copy-file-targets + nil t)) + (`(,dest ,staging) (alist-get name my-copy-file-targets + nil nil #'equal))) + (my-copy-file-with-staging + nov-file-name dest staging))) + +(defun my-nov-set-margins () + ;; Does not work as well as setq left- and right-margin-width + ;; (set-window-margins nil 3 2) + (setq left-margin-width 3) + (setq right-margin-width 2) + ;; Does not work as well as setq left- and right-fringe-width + ;; (set-window-fringes nil 0 0) + (setq left-fringe-width 0) + (setq right-fringe-width 0) + (visual-line-mode) + ) + +(defvar-local my-nov-document-word-counts nil + "Word count of each nov document.") + +(defvar-local my-nov-total-word-count nil + "Total word count of the epub.") + +(defun my-nov-count-words () + (interactive) + (unless my-nov-document-word-counts + (message "Counting words...") + (setq my-nov-document-word-counts + (apply + 'vector + (seq-map + (lambda (doc) + (with-temp-buffer + (pcase-let ((`(,name . ,file) doc)) + (insert-file-contents file) + (nov-render-html) + (cons name (count-words (point-min) (point-max)))))) + nov-documents))) + (setq my-nov-total-word-count + (seq-reduce + (lambda (sum pair) + (+ sum (cdr pair))) + my-nov-document-word-counts + 0)) + (message "Counting words...done"))) + +(defun my-nov-stats () + (interactive) + (message "%d words; %d standard pages" + my-nov-total-word-count + (ceiling (/ my-nov-total-word-count 300.0)))) + +;;; TODO: also show current percentage in the total book in the mode +;;; line +(defun my-nov-goto-nth-word (n) + "Go to the nth word of the current epub." + (my-nov-count-words) + (setq nov-documents-index -1) + (let ((found + (seq-find + (lambda (pair) + (setq n (- n (cdr pair))) + (setq nov-documents-index (1+ nov-documents-index)) + (<= n 0)) + my-nov-document-word-counts))) + (nov-render-document) + (if (> n 0) + (end-of-buffer) + (forward-word (+ n (cdr found))))) + ) + +(defun my-nov-word-position () + "Where are we in terms of word position? + +Return n, such that nth word of the epub is at the beginning of the +screen." + (my-nov-count-words) + (let ((result 0)) + (dotimes (i nov-documents-index) + (setq result (+ result (cdr (aref my-nov-document-word-counts i))))) + (save-excursion + (move-to-window-line 0) + (setq result (+ result (count-words (point-min) (point))))))) + +(defun my-nov-skim-forward () + "Forward by 3-10% of the book." + (interactive) + (let ((pc (+ 3 (random 8)))) + (my-nov-goto-nth-word + (+ (my-nov-word-position) + (/ (* my-nov-total-word-count pc) 100))) + (message "Skimmed forward by %d%% of the book" pc))) + +(defun my-nov-skim-backward () + "Backward by 3-10% of the book." + (interactive) + (let ((pc (+ 3 (random 8)))) + (my-nov-goto-nth-word + (max + 0 + (- (my-nov-word-position) + (/ (* my-nov-total-word-count pc) 100)))) + (message "Skimmed backward by %d%% of the book" pc))) + +(defun my-nov-goto-random-position () + "Goto a random position in the epub." + (interactive) + (my-nov-count-words) + (let ((n (random my-nov-total-word-count))) + (my-nov-goto-nth-word n) + (message "Went to the %dth word (%d%% of the book)." + n (/ (* n 100) my-nov-total-word-count)))) + (provide 'my-nov) ;;; my-nov.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-org-jira.el b/emacs/.emacs.d/lisp/my/my-org-jira.el index 2502f02..9e2f821 100644 --- a/emacs/.emacs.d/lisp/my/my-org-jira.el +++ b/emacs/.emacs.d/lisp/my/my-org-jira.el @@ -82,7 +82,7 @@ :proj-key (path '(fields project key)) :related-issues (mapconcat (lambda (c) - (print c) + ;; (print c) (if (org-jira-sdk-path c '(inwardIssue)) (if (equal (org-jira-sdk-path @@ -269,5 +269,13 @@ (interactive) (kill-new (my-org-jira-comment-url-at-point))) +(defun my-org-jira-url-p (url) + (string-match-p (format "^%s/browse/[^/]" jiralib-url) url)) + +(defun my-org-jira-open-url (url) + (interactive "sJIRA issue url: ") + (when (string-match (format "^%s/browse/\\([^/]+\\)" jiralib-url) url) + (org-jira-get-issue (match-string 1 url)))) + (provide 'my-org-jira) ;;; my-org-jira.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-org-remark.el b/emacs/.emacs.d/lisp/my/my-org-remark.el new file mode 100644 index 0000000..4582f6c --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-org-remark.el @@ -0,0 +1,101 @@ +;;; my-org-remark.el -- customization to org-remark -*- lexical-binding: t -*- + +;; Copyright (C) 2025 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "29.4")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; customization to org-remark. + +;;; Code: + + +;;; override `org-remark-highlight-add-or-update-highlight-headline' +(defun my-org-remark-highlight-add-or-update-highlight-headline (highlight source-buf notes-buf) + "Add a new HIGHLIGHT headlne to the NOTES-BUF or update it. +Return notes-props as a property list. + +HIGHLIGHT is an overlay from the SOURCE-BUF. + +Assume the current buffer is NOTES-BUF and point is placed on the +beginning of source-headline, which should be one level up." + ;; Add org-remark-link with updated line-num as a property + (let (title beg end props id text filename link orgid org-remark-type other-props) + (with-current-buffer source-buf + (setq title (org-remark-highlight-get-title) + beg (overlay-start highlight) + end (overlay-end highlight) + props (overlay-properties highlight) + id (plist-get props 'org-remark-id) + org-remark-type (overlay-get highlight 'org-remark-type) + text (org-with-wide-buffer + (org-remark-highlight-headline-text highlight org-remark-type)) + filename (org-remark-source-get-file-name + (org-remark-source-find-file-name)) + link (run-hook-with-args-until-success + 'org-remark-highlight-link-to-source-functions filename beg) + orgid (org-remark-highlight-get-org-id beg) + other-props (org-remark-highlight-collect-other-props highlight)) + ;; TODO ugly to add the beg end after setq above + (plist-put props org-remark-prop-source-beg (number-to-string beg)) + (plist-put props org-remark-prop-source-end (number-to-string end)) + (when link (plist-put props "org-remark-link" link)) + (when other-props (setq props (append props other-props)))) + ;;; Make it explicit that we are now in the notes-buf, though it is + ;;; functionally redundant. + (with-current-buffer notes-buf + (let ((highlight-headline (org-find-property org-remark-prop-id id)) + ;; Assume point is at the beginning of the parent headline + (level (1+ (org-current-level)))) + (if highlight-headline + (progn + (goto-char highlight-headline) + ;; Update the existing headline and position properties + ;; Don't update the headline text when it already exists. + ;; Let the user decide how to manage the headlines + ;; (org-edit-headline text) + (org-remark-notes-set-properties props)) + ;; No headline with the marginal notes ID property. Create a new one + ;; at the end of the file's entry + (org-narrow-to-subtree) + (goto-char (point-max)) + ;; Ensure to be in the beginning of line to add a new headline + (when (eolp) (open-line 1) (forward-line 1) (beginning-of-line)) + ;; Create a headline + ;; Add a properties + (insert (concat (insert-char (string-to-char "*") level) + " " (my-elide-text text fill-column) "\n")) + ;; org-remark-original-text should be added only when this + ;; headline is created. No update afterwards + (plist-put props "org-remark-original-text" text) + (org-remark-notes-set-properties props) + (when (and orgid org-remark-use-org-id) + (insert (concat "[[id:" orgid "]" "[" title "]]")))) + (list :body (org-remark-notes-get-body) + :original-text text))))) + +(defun my-org-remark-open-or-create () + (interactive) + (if mark-active + (call-interactively 'org-remark-mark) + (call-interactively 'org-remark-open))) + +(provide 'my-org-remark) +;;; my-org-remark.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-org.el b/emacs/.emacs.d/lisp/my/my-org.el index ad0c3cb..e628c5b 100644 --- a/emacs/.emacs.d/lisp/my/my-org.el +++ b/emacs/.emacs.d/lisp/my/my-org.el @@ -81,7 +81,12 @@ buffer was a live window.") (defun my-org-edit-src-before-exit () "A :before advice for org-edit-src-exit." - (delete-trailing-whitespace) + (goto-char (point-min)) + (and + (>= (skip-chars-forward "\n") 1) + (region-modifiable-p (point-min) (point)) + (delete-region (point-min) (point))) + (let ((delete-trailing-lines t)) (delete-trailing-whitespace)) (setq my-org-edit-src-was-live-window (get-buffer-window (current-buffer)))) (defun my-org-element-block-p (element) @@ -812,8 +817,6 @@ When BLOCK-REGEXP is non-nil, use this regexp to find blocks." (cl-letf (((symbol-function 'delete-other-windows) 'ignore)) (apply oldfun args))) -(defvar my-org-attach-copy-attached-targets nil - "Alist of targets to copy attached to, in the form of (name . path)") (defvar my-org-attach-copy-attached-doc-exts '("epub" "pdf" "mobi")) (defvar my-org-attach-copy-attached-doc-re @@ -832,44 +835,15 @@ On success, also move everything from staging to to-dir." (interactive) (pcase-let* ((name (completing-read "Copy attached docs to: " - my-org-attach-copy-attached-targets + my-copy-file-targets nil t)) - (`(,to ,staging) (alist-get name my-org-attach-copy-attached-targets + (`(,to ,staging) (alist-get name my-copy-file-targets nil nil #'equal))) - (let ((basedir (org-attach-dir)) - (failed nil)) - (dolist (attached (org-attach-file-list basedir)) - (when (string-match my-org-attach-copy-attached-doc-re attached) - (message "Copying %s to %s (%s)..." attached name to) - (condition-case nil - (copy-file (file-name-concat basedir attached) - (file-name-concat - to - (replace-regexp-in-string ":" "_" attached)) - t) - (error - (message "Hardlinking %s to %s staging area (%s)" - attached name staging) - (setq failed t) - (add-name-to-file - (file-name-concat basedir attached) - (file-name-concat - staging - (replace-regexp-in-string ":" "_" attached)) - t))) - (message "Done!"))) - (unless failed - (dolist (staged - (directory-files staging nil - my-org-attach-copy-attached-doc-re)) - (message "Moving staged %s to %s (%s)..." staged name to) - (copy-file (file-name-concat staging staged) - (file-name-concat - to - (replace-regexp-in-string ":" "_" staged)) - t) - (delete-file (file-name-concat staging staged)) - (message "Done!")))))) + (my-copy-files-with-staging + (directory-files-recursively (org-attach-dir) + my-org-attach-copy-attached-doc-re) + to + staging))) (defun my-org-attach-all-url-plaintext (arg) (interactive "P") @@ -1088,6 +1062,11 @@ On success, also move everything from staging to to-dir." (org-protocol-grok (list :url (plist-get eww-data :url)))) +(defun my-org-protocol-browse-url (data) + (when-let ((url (plist-get data :url))) + (browse-url url)) + nil) + ;; org capture rss (defun my-org-rss-xml-create-audio-node (url) (interactive (list (read-string "Feed URL: " @@ -1176,21 +1155,47 @@ On success, also move everything from staging to to-dir." (require 'org-recoll) "Format recoll results in buffer." ;; Format results in org format and tidy up - (org-recoll-regexp-replace-in-buffer - "^.*?\\[\\(.*?\\)\\]\\s-*\\[\\(.*?\\)\\]\\(.*\\)$" - "* [[\\1][\\2]] <\\1>\\3") - (org-recoll-regexp-replace-in-buffer - (format "<file://.*?%s\\(.*/\\).*>" (substring my-docs-root-dir 1)) - "(\\1)") + (org-recoll-regexp-replace-in-buffer "file://" "file:") + (goto-char (point-min)) + (delete-trailing-whitespace) + (while (re-search-forward + "^.*?\\[\\(.*?\\)\\]\\s-*\\[\\(.*?\\)\\]\\(.*\\)$" nil t) + (let ((file-name (match-string 1)) + (title (match-string 2)) + (size (match-string 3))) + (replace-match + (format "* %s (%s)%s" + (org-link-make-string file-name title) + (file-name-nondirectory file-name) + size) + t + t))) (org-recoll-regexp-replace-in-buffer "\\/ABSTRACT" "") (org-recoll-regexp-replace-in-buffer "ABSTRACT" "") ;; Justify results (goto-char (point-min)) (org-recoll-fill-region-paragraphs) ;; Add emphasis - (highlight-phrase (org-recoll-reformat-for-file-search - org-recoll-search-query) - 'bold-italic)) + (let ((search-whitespace-regexp "[ ]+")) + (highlight-phrase (org-recoll-reformat-for-file-search + org-recoll-search-query) + 'bold-italic))) + +(defun my-org-recoll-query (query) + ;; caddr contains number of results + (seq-map + (lambda (line) + (pcase-let ((`(,title ,filename ,ipath ,abstract) + (seq-map 'base64-decode-string (split-string line " ")))) + `((title . ,title) + (filename . ,filename) + (ipath . ,ipath) + (abstract . ,abstract)))) + (cdddr + (string-lines + (my-call-process-out + "recollq" "-F" "title filename ipath abstract" "-n" "0-40" "-q" query)))) + ) (defun my-org-recoll-mdn (query) (interactive "sSearch mdn: ") @@ -1365,7 +1370,7 @@ With a prefix arg, yank and exit immediately." (org-edit-src-exit)))) ;; used to add an :after advice to `org-edit-special'. -(defun my-org-edit-special-after () +(defun my-org-edit-special-after (&rest _) ;; some modes (e.g. diff mode) are read-only by default, which ;; does not make sense when the intention is to edit (read-only-mode 0)) @@ -1657,5 +1662,28 @@ dual relation link-back on that task." (and (org-entry-get (point) "BLOCKED_BY") (member (org-entry-get nil "TODO") org-not-done-keywords))) +(defun my-org-clock-split () + "Split the clock entry at the current line." + (interactive) + (let ((line (buffer-substring (line-beginning-position) (line-end-position)))) + (unless (string-match org-element-clock-line-re line) + (error "Not at an org clock line")) + (let* ((start (match-string 1 line)) + (end (match-string 2 line)) + (mid (org-read-date t 'to-time nil "Split org clock at: " nil start))) + (back-to-indentation) + (kill-line) + (insert "CLOCK: [" start "]--") + (org-insert-time-stamp mid t t) + (org-clock-update-time-maybe) + + (my-new-line-above-or-below) + (insert "CLOCK: ") + (org-insert-time-stamp mid t t) + (insert "--[" end "]") + (org-clock-update-time-maybe) + )) + ) + (provide 'my-org) ;;; my-org.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-package.el b/emacs/.emacs.d/lisp/my/my-package.el index b591d0f..ab3ad77 100644 --- a/emacs/.emacs.d/lisp/my/my-package.el +++ b/emacs/.emacs.d/lisp/my/my-package.el @@ -216,6 +216,17 @@ same name, cancel that one first." (cancel-timer ,var-name)) (setq ,var-name (run-with-timer ,secs ,repeat ,function)))) +(defmacro my-timer (var-name secs repeat function) + "Create a timer. + +The timer has name VAR-NAME. If there is an existing time with the +same name, cancel that one first." + + `(progn + (when (and (boundp ',var-name) (timerp ,var-name)) + (cancel-timer ,var-name)) + (setq ,var-name (run-with-timer ,secs ,repeat ,function)))) + (defun my-describe-package-from-url (url) (interactive "sUrl: ") (when (string-match @@ -263,7 +274,7 @@ same name, cancel that one first." (add-hook hook function))) (defvar my-common-packages - '(package windmove consult icomplete + '(package windmove consult corfu icomplete isearch paredit my-utils my-buffer my-editing my-complete) "Common packages to include with any profile") diff --git a/emacs/.emacs.d/lisp/my/my-prog.el b/emacs/.emacs.d/lisp/my/my-prog.el index 396d919..92fcf21 100644 --- a/emacs/.emacs.d/lisp/my/my-prog.el +++ b/emacs/.emacs.d/lisp/my/my-prog.el @@ -365,8 +365,28 @@ left and the source buffer on the right. (select-window (display-buffer (gdb-get-source-buffer)))) (defun my-gud-comint-set-prompt-regexp () - (setq comint-prompt-regexp "\\((rr)|(gdb)\\) ")) + (setq comint-prompt-regexp "\\((rr)\\|(gdb)\\) *")) +(defun my-gud-source-line () + (with-current-buffer (gdb-get-source-buffer) + (buffer-substring (progn (beginning-of-line) (point)) + (progn (end-of-line) (point))))) + +(defun my-gud-function-name () + (with-current-buffer (gdb-get-source-buffer) + (which-function))) + +(defun my-gud-insert-source-line () + (interactive) + (insert (my-gud-source-line))) + +(defun my-gud-insert-function-name () + (interactive) + (insert (my-gud-function-name))) + +(defun my-gud-insert-source-line-and-function-name () + (interactive) + (insert (format "%s IN %s" (my-gud-source-line) (my-gud-function-name)))) ;;; used to override `gdb-frame-handler': do not re-display frame on ;;; completion. @@ -419,9 +439,27 @@ overlay arrow in source buffer." ;; (gdb-input (concat "complete " context command) ;; (lambda () (setq gud-gdb-fetch-lines-in-progress nil))) ;; (while gud-gdb-fetch-lines-in-progress -;; (accept-process-output (get-buffer-process gud-comint-buffer) 1))) +;; (accept-process-output (get-buffer-process gud-comint-buffer) .1))) ;; (gud-gdb-completions-1 gud-gdb-fetched-lines))) +(defun my-gud-watch-expr (expr) + (with-current-buffer gud-comint-buffer + (insert "watch -l " expr) + (comint-send-input))) + +(defun my-gud-print-expr (expr) + (with-current-buffer gud-comint-buffer + (insert "p " expr) + (comint-send-input))) + +(defun my-gud-print-expr-region (b e) + (interactive "r") + (unless (eq (gdb-get-source-buffer) (current-buffer)) + (error "Not in the source buffer")) + (if current-prefix-arg + (my-gud-watch-expr (buffer-substring b e)) + (my-gud-print-expr (buffer-substring b e)))) + ;;; which-func (defun my-copy-which-func () (interactive) @@ -489,6 +527,34 @@ overlay arrow in source buffer." (unless (derived-mode-p 'haskell-mode 'c-mode 'c++-mode) (eglot-format-buffer)))) +;;; https://github.com/joaotavora/eglot/issues/88 +(defun my-eglot-ccls-inheritance-hierarchy (&optional derived) + "Show inheritance hierarchy for the thing at point. +If DERIVED is non-nil (interactively, with prefix argument), show +the children of class at point." + (interactive "P") + (if-let* ((res (jsonrpc-request + (eglot--current-server-or-lose) + :$ccls/inheritance + (append (eglot--TextDocumentPositionParams) + `(:derived ,(if derived t :json-false)) + '(:levels 100) '(:hierarchy t)))) + (tree (list (cons 0 res)))) + (with-help-window "*ccls inheritance*" + (with-current-buffer standard-output + (while tree + (pcase-let ((`(,depth . ,node) (pop tree))) + (cl-destructuring-bind (&key uri range) (plist-get node :location) + (insert (make-string depth ?\ ) (plist-get node :name) "\n") + (make-text-button (+ (point-at-bol 0) depth) (point-at-eol 0) + 'action (lambda (_arg) + (interactive) + (find-file (eglot--uri-to-path uri)) + (goto-char (car (eglot--range-region range))))) + (cl-loop for child across (plist-get node :children) + do (push (cons (1+ depth) child) tree))))))) + (eglot--error "Hierarchy unavailable"))) + ;;; lisp (defun my-eval-defun-or-region (&optional arg) "Call `eval-region' if region is active, otherwise call `eval-defun'" diff --git a/emacs/.emacs.d/lisp/my/my-utils.el b/emacs/.emacs.d/lisp/my/my-utils.el index bc200c2..0743227 100644 --- a/emacs/.emacs.d/lisp/my/my-utils.el +++ b/emacs/.emacs.d/lisp/my/my-utils.el @@ -304,6 +304,13 @@ Example: (format-time-string ... (my-time-from-epoch 1698582504))" ,@body (setq default-directory saved))) + +(defun my-call-process-out (command &rest args) + "Call `call-process' on COMMAND with ARGS and return the output." + (with-temp-buffer + (apply 'call-process (append (list command nil t nil) args)) + (buffer-string))) + (defun my-call-process-with-torsocks (program &optional infile destination display &rest args) (apply 'call-process @@ -321,7 +328,7 @@ Example: (format-time-string ... (my-time-from-epoch 1698582504))" (defvar my-extension-types '((audio . ("asf" "cue" "flac" "m4a" "m4r" "mid" "mp3" "ogg" "opus" - "wav" "wma" "spc")) + "wav" "wma" "spc" "mp4")) (video . ("avi" "m4v" "mkv" "mp4" "mpg" "ogg" "ogv" "rmvb" "webm" "wmv")))) ;;; files @@ -332,6 +339,75 @@ Example: (format-time-string ... (my-time-from-epoch 1698582504))" (make-symbolic-link newname file ok-if-already-exists) newname) +(defvar my-copy-file-targets nil + "Alist of targets to copy attached to, in the form of (name dest staging)") + +(defun my-copy-buffer-file-with-staging () + (interactive) + (unless (buffer-file-name) (error "buffer-file-name is nil")) + (pcase-let* ((name + (completing-read (format "Copy %s to: " (buffer-file-name)) + my-copy-file-targets + nil t)) + (`(,dest ,staging) (alist-get name my-copy-file-targets + nil nil #'equal))) + (my-copy-file-with-staging + (buffer-file-name) dest staging))) + +(defun my-flush-staging-files (staging dest) + "Flush files from STAGING to DEST." + (dolist (staged (directory-files staging)) + (unless (file-directory-p (file-name-concat staging staged)) + (message "Moving staged %s to %s..." staged dest) + (copy-file (file-name-concat staging staged) + (file-name-concat dest staged) + t) + (delete-file (file-name-concat staging staged))))) + +(defun my-flush-staging-files-x () + (interactive) + (pcase-let* ((name + (completing-read (format "Copy %s to: " (buffer-file-name)) + my-copy-file-targets + nil t)) + (`(,dest ,staging) (alist-get name my-copy-file-targets + nil nil #'equal))) + (my-flush-staging-files staging dest))) + +(defun my-copy-file-with-staging (src dest staging) + "Copy a file SRC to DEST with fallback to hardlinking to STAGING." + (my-copy-files-with-staging (list src) dest staging)) + +(defun my-copy-files-with-staging (src dest staging) + "Copy a list of file SRC to DEST with staging. + +DEST and STAGING should be directories. +On failure, hard link to STAGING. +On success, also move everything from STAGING to DEST." + (cl-assert (listp src)) + (let (failed) + (dolist (file src) + (cond + ((not failed) + (message "Copying %s to %s..." file dest) + (condition-case err + (copy-file + file (file-name-concat dest (file-name-nondirectory file)) t) + (error + (message "Encountered error while copying: %s" + (error-message-string err)) + (message "Hardlinking instead %s to staging area %s" src staging) + (setq failed t) + (add-name-to-file + file (file-name-concat staging (file-name-nondirectory file)) t)))) + (t + (message "Hardlinking %s staging area %s" src staging) + (add-name-to-file + file (file-name-concat staging (file-name-nondirectory file)) t)))) + (unless failed + (my-flush-staging-files staging dest)) + (message "Done!"))) + (defun my-rewrite-url-advice (args) (let ((url (car args))) (setcar args (my-rewrite-url url))) diff --git a/emacs/.emacs.d/lisp/my/my-web.el b/emacs/.emacs.d/lisp/my/my-web.el index 311bcf9..7c9c567 100644 --- a/emacs/.emacs.d/lisp/my/my-web.el +++ b/emacs/.emacs.d/lisp/my/my-web.el @@ -86,19 +86,6 @@ (start-process (concat "mullvad-browser " url) nil "mullvad-browser" url)) -;; TODO: change to using hmm matching url with default app -;; override browse-url -(defun my-browse-url (url &optional arg) - (interactive "P") - (cond ((equal arg '(4)) - (funcall browse-url-secondary-browser-function url)) - ((equal arg '(16)) - (my-browse-url-tor-browser url)) - (t (luwak-open url)))) - -;; this fixes clicking url buttons like those in gnus messages -(defalias 'browse-url-button-open-url 'my-browse-url) - (defun my-browse-url-at-point (arg) (interactive "P") (my-browse-url (browse-url-url-at-point) arg)) @@ -148,5 +135,122 @@ (kill-new url) (message "Copied link: %s" url))) +;;; webgetter +(require 'my-net) +(defun my-fetch-browse (url &optional no-overwrite) + "Fetch URL to a local file then browse it with firefox. + +Useful for bypassing \"Enable JavaScript and cookies to continue\"." + (interactive "sUrl to fetch and browse: ") + (let ((file-name + (if no-overwrite + (my-make-unique-file-name + (my-make-file-name-from-url url) + my-webpage-download-dir) + (expand-file-name + (my-make-file-name-from-url url "html") + my-webpage-download-dir)))) + (url-copy-file url file-name (not no-overwrite)) + (browse-url-firefox (format "file://%s" file-name)))) + +(defun my-fetch-browse-as-googlebot (url &optional no-overwrite) + "Same as `my-fetch-browse', but spoofing googlebot. + +Useful for bypassing some paywalls." + (interactive "sUrl to fetch and browse as googlebot: ") + (my-url-as-googlebot + (my-fetch-browse url no-overwrite))) + +(require 'hmm) +(defvar my-url-context-function 'hmm-url "Context function for urls.") +(defvar my-file-context-function 'hmm-file "Context function for files.") + +(defun my-hacker-news-url-p (url) + "Check if a url is a hacker news post. +e.g. https://news.ycombinator.com/item?id=42505454" + (let ((urlobj (url-generic-parse-url url))) + (and (equal "news.ycombinator.com" (url-host urlobj)) + (string-match-p "^/item\\?id=[0-9]+$" (url-filename urlobj))))) + +(defvar my-newscorp-au-amp-nk nil) +(defun my-open-newscorp-au (url) + (interactive "sNews Corp AU link: ") + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj))) + (setf (url-filename urlobj) + (format "%s?amp&nk=%s" path my-newscorp-au-amp-nk)) + (browse-url-firefox (url-recreate-url urlobj)))) + +(defun my-newscorp-au-url-p (url) + (string-match-p "^\\(www\\.\\)?\\(heraldsun\\|theaustralian\\)\\.com\\.au$" + (url-host (url-generic-parse-url url)))) + +(defun my-stack-overflow-url-p (url) + "Guess whether a url stack overflow question +e.g. +https://emacs.stackexchange.com/questions/40887/in-org-mode-how-do-i-link-to-internal-documentation" + (pcase-let* ((urlobj (url-generic-parse-url url)) + (`(,path . _) (url-path-and-query urlobj))) + (string-match-p "^/questions/[0-9]+/.+$" path)) ) + +(advice-add 'server-visit-files :around #'my-ec-handle-http) +(defun my-ec-handle-http (orig-fun files client &rest args) + ;; (message "GOT %s" files) + (dolist (var files) + (let ((fname (expand-file-name (car var)))) + (when (string-match ".*/?\\(https?:\\)/+" fname) + (browse-url (replace-match "\\1//" nil nil fname)) + (setq files (delq var files))))) + (apply orig-fun files client args)) + +(defvar my-firefox-profile-dir nil "Firefox profile dir") +(defvar my-firefox-place-limit 1000 "Firefox urls result limit") + +(defun my-firefox-places (&optional query) + (let ((where + (mapconcat + (lambda (word) (format "(url LIKE '%%%s%%' OR title LIKE '%%%s%%')" word word)) + (split-string (or query "")) + " AND "))) + (unless (string-empty-p where) (setq where (format "WHERE %s" where))) + (with-temp-buffer + (call-process "sqlite3" nil t nil + (format "file://%s/places.sqlite?immutable=1" + (expand-file-name my-firefox-profile-dir)) + (format + "SELECT url,title FROM moz_places %s ORDER BY visit_count desc limit %d" + where + my-firefox-place-limit)) + (string-lines (buffer-string)) + ))) + +(defun my-firefox-places-collection (query pred action) + (if (eq action 'metadata) + `(metadata (display-sort-function . ,#'identity) + ;; Needed for icomplete to respect list order + (cycle-sort-function . ,#'identity)) + (let ((candidates (my-firefox-places query))) + (message "Got %d candidates for query %s. Current action is %s" (length candidates) query action) + (cl-loop for str in-ref candidates do + (setf str (orderless--highlight regexps ignore-case (substring str)))) + candidates + ;; Does not show remotely as many results + ;; (complete-with-action action candidates query pred) + ))) + +(defun my-browse-url (url) + (interactive (list (completing-read "URL to browse: " + #'my-firefox-places-collection))) + (message url)) + +(defun my-forge-infobox-format-url (url) + (concat url + " -- " (buttonize "clone" + (lambda (_) + (my-magit-clone url current-prefix-arg))) + " " (buttonize "context" + (lambda (_) + (funcall my-url-context-function url))))) + (provide 'my-web) ;;; my-web.el ends here diff --git a/emacs/.emacs.d/lisp/my/my-wget.el b/emacs/.emacs.d/lisp/my/my-wget.el index 5349257..e7283aa 100644 --- a/emacs/.emacs.d/lisp/my/my-wget.el +++ b/emacs/.emacs.d/lisp/my/my-wget.el @@ -48,20 +48,31 @@ (kill-new full-path) (message "Saved webpage to %s (path copied)." full-path))) -(defun my-wget-async (url filename &optional no-tor move-if-video-or-large) +(defun my-wget-async (url filename &optional no-tor on-success on-fail) (set-process-sentinel (my-start-process-with-torsocks no-tor "wget" "*wget*" "wget" url "-c" "-O" filename) - (lambda (_process _event) - (when (and move-if-video-or-large - (or - (> (file-attribute-size (file-attributes filename)) - my-wget-size-threshold) - (member (file-name-extension filename) my-wget-video-extensions))) - (setq filename - (my-rename-and-symlink-back - filename (expand-file-name my-wget-video-archive-directory) nil))) - (message "Fetched %s and saved to: %s" url filename)))) + (lambda (proc event) + (let ((ps (process-status proc)) + (status (process-exit-status proc))) + (if (eq status 0) + (progn + (message "[DONE] Fetched %s to %s" url filename) + (when on-success (funcall on-success))) + (message "[FAIL] Fetching %s to %s: %s" url filename event) + (when on-fail (funcall on-fail)))) + ) + )) + +(defun my-wget-move-if-video-or-large (url filename _process _event) + (when (or + (> (file-attribute-size (file-attributes filename)) + my-wget-size-threshold) + (member (file-name-extension filename) my-wget-video-extensions)) + (setq filename + (my-rename-and-symlink-back + filename (expand-file-name my-wget-video-archive-directory) nil))) + (message "Fetched %s and saved to: %s" url filename)) (defun wget-async-urls-with-prefix (urls prefix &optional no-tor move-if-video-or-large) (let ((i 1)) diff --git a/emacs/.emacs.d/lisp/my/my-ytdl.el b/emacs/.emacs.d/lisp/my/my-ytdl.el index 9118493..b3b1cf7 100644 --- a/emacs/.emacs.d/lisp/my/my-ytdl.el +++ b/emacs/.emacs.d/lisp/my/my-ytdl.el @@ -76,6 +76,67 @@ (if (eq type 'video) my-ytdl-video-args my-ytdl-audio-args) (split-string urls))))) +(defun my-ytdl-video-info (url) + "Given a video URL, return an alist of its properties." + (with-temp-buffer + (call-process my-ytdl-program nil t nil "--no-warnings" "-j" url) + (let ((start (point))) + (call-process-region + nil nil "jq" nil t nil + "pick(.webpage_url, .fulltitle, .channel_url, .channel, .channel_follower_count, .thumbnail, .duration_string, .view_count, .upload_date, .like_count, .is_live, .was_live, .categories, .tags, .chapters, .availability, .uploader, .description)") + (goto-char start) + (json-read))) + ) + +(defun my-ytdl-video-url-p (url) + (let ((urlobj (url-generic-parse-url url))) + (or (and (string-match-p + "^\\(www\\.\\)?\\(youtube\\.com\\|yewtu\\.be\\)" + (url-host urlobj)) + (string-match-p "^/watch\\?v=.*" (url-filename urlobj))) + (equal "youtu.be" (url-host urlobj))))) + +(require 'hmm) +(defvar my-ytdl-player 'hmm-external-mpv "Function to play ytdl urls.") + +(defun my-ytdl-video-format-seconds (secs) + (setq secs (floor secs)) + (if (>= secs 3600) + (format "%d:%02d:%02d" + (/ secs 3600) (/ (% secs 3600) 60) (% secs 60)) + (format "%d:%02d" + (/ secs 60) (% secs 60)))) + +(defun my-ytdl-video-format-chapters (chapters) + (mapconcat + (lambda (chapter) + (let-alist chapter + (format "%s: %s-%s" .title (my-ytdl-video-format-seconds .start_time) + (my-ytdl-video-format-seconds .end_time)))) + chapters + "; ")) + +(defun my-ytdl-video-render-info (info url) + (setf (alist-get 'webpage_url info) + (concat (alist-get 'webpage_url info) + " -- " (buttonize "play" (lambda (_) + (funcall my-ytdl-player url))) + " " (buttonize "context" + (lambda (_) + (funcall my-url-context-function url)))) + (alist-get 'chapters info) + (my-ytdl-video-format-chapters (alist-get 'chapters info))) + (infobox-render + (infobox-translate info (infobox-default-specs info)) + `(my-ytdl-video-infobox ,url) + (called-interactively-p 'interactive))) + +(defun my-ytdl-video-infobox (url) + (interactive "sytdl video url: ") + ;; Remove any extra queries from the URL + (setq url (replace-regexp-in-string "&.*" "" url)) + (my-ytdl-video-render-info (my-ytdl-video-info url) url)) + ;;; fixme: autoload (defun my-ytdl-video (urls) "Download videos with ytdl." diff --git a/emacs/.emacs.d/lisp/my/reddio.el b/emacs/.emacs.d/lisp/my/reddio.el new file mode 100644 index 0000000..f8bc77f --- /dev/null +++ b/emacs/.emacs.d/lisp/my/reddio.el @@ -0,0 +1,80 @@ +;;; reddio.el -- reddit client through reddio -*- lexical-binding: t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Yuchen Pei <id@ypei.org> +;; Package-Requires: ((emacs "29.4")) + +;; This file is part of dotted. + +;; dotted 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. + +;; dotted 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 dotted. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; reddit client through reddio. + +;;; Code: + +(defvar reddio-buffer "*reddio*") + +(defvar reddio-dir (locate-user-emacs-file "reddio") + "Path to local directory of saved threads.") + +(defun reddio-make-filename (url) + (string-match "/r/\\([^/]+\\)/comments/\\([^/]+\\)/\\([^/]+\\)" url) + (file-name-concat + reddio-dir + (format "%s.%s.%s.txt" + (match-string 1 url) + (match-string 3 url) + (match-string 2 url)))) + +(defun reddio-save-text-and-switch-to-buffer (text file-name) + "Save TEXT to FILE-NAME and switch to buffer." + (let ((buffer (find-file-noselect file-name)) + (coding-system-for-write 'utf-8)) + (with-current-buffer buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert text)) + (goto-char (point-min)) + (save-buffer) + (revert-buffer t t)) + (switch-to-buffer buffer))) + +(defun reddio-open-url (url) + (interactive "sReddit link: ") + (let ((text + (when (string-match "/\\(comments/[^/]+\\)/" url) + (with-temp-buffer + (if (= 0 (call-process "reddio" nil (current-buffer) nil + "print" "-l" "500" + (match-string 1 url))) + (goto-char (point-min)) + (error "reddio process failed: %s" (buffer-string))) + (delete-trailing-whitespace) + (buffer-string))))) + (reddio-save-text-and-switch-to-buffer + text + (reddio-make-filename url)))) + +(defun reddio-reddit-url-p (url) + "e.g. +https://www.reddit.com/r/linux/comments/cs3os6/introducing_reddio_a_commandline_interface_for/" + (let ((urlobj (url-generic-parse-url url))) + (and (string-match-p "^.*\\<reddit.com$" (url-host urlobj)) + (string-match-p "^/r/[^/]+/comments/[^/]+/.+$" (url-filename urlobj))))) + +(provide 'reddio) +;;; reddio.el ends here |