From 093ffa5fbf7143f4668bb0a3dc9659a5cc836e12 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Sat, 17 Jun 2023 17:20:29 +1000 Subject: Moving things one level deeper To ease gnu stow usage. Now we can do stow -t ~ emacs --- emacs/.emacs.d/lisp/my/my-org.el | 1003 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 1003 insertions(+) create mode 100644 emacs/.emacs.d/lisp/my/my-org.el (limited to 'emacs/.emacs.d/lisp/my/my-org.el') diff --git a/emacs/.emacs.d/lisp/my/my-org.el b/emacs/.emacs.d/lisp/my/my-org.el new file mode 100644 index 0000000..cb72677 --- /dev/null +++ b/emacs/.emacs.d/lisp/my/my-org.el @@ -0,0 +1,1003 @@ +;;; my-org.el -- Extensions for org -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation. + +;; Author: Yuchen Pei +;; Package-Requires: ((emacs "28.2")) + +;; This file is part of dotfiles. + +;; dotfiles is free software: you can redistribute it and/or modify it under +;; the terms of the GNU Affero General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; dotfiles is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General +;; Public License for more details. + +;; You should have received a copy of the GNU Affero General Public +;; License along with dotfiles. If not, see . + +;;; Commentary: + +;; Extensions for org. + +;;; Code: + + +(require 'org) + +;;; org mode +(defun my-org-open-shell-at-attach-dir () + (interactive) + (require 'my-prog) + (my-shell-with-directory (concat (org-attach-dir-get-create) "/"))) + +(defun my-org-links-in-entry () + "Get all link urls in an entry" + (save-excursion + (org-back-to-heading t) + (let (links + (end (save-excursion (outline-next-heading) (point)))) + (while (re-search-forward org-link-any-re end t) + (push + (org-unbracket-string "<" ">" + (or + ;; [[target][desc]] + (match-string-no-properties 2) + ;; plain link or <...> + (match-string-no-properties 0))) + links)) + links))) + +(defun my-org-http-s-links-in-entry () + "Get all http(s) urls in an entry" + (seq-filter (lambda (link) + (string-prefix-p + "http" + (progn (string-match org-link-types-re link) + (match-string 1 link)))) + (my-org-links-in-entry))) + +(defun my-org-insert-date-range (inactive) + "Insert two dates to form an active date range. + +With a prefix, insert inactive dates. +" + (interactive "P") + (org-time-stamp nil inactive) + (insert "--") + (org-time-stamp nil inactive)) + +(defun my-org-follow-link-after () + (when (eq major-mode 'mhtml-mode) + (browse-url-of-buffer))) + +;; navigation +(defun my-org-jump-to-last-visible-child () + "Goto the last visible child." + (interactive) + (let (level (pos (point)) (re org-outline-regexp-bol)) + (when (ignore-errors (org-back-to-heading t)) + (setq level (outline-level)) + (forward-char 1) + (while (and (re-search-forward re nil t) (> (outline-level) level)) + (when (and (= (outline-level) (1+ level)) + (not (get-char-property (point) 'invisible))) + (setq pos (match-beginning 0))))) + (goto-char pos))) + +(defun my-org-entry-toggle-drawer-visibility () + (interactive) + (save-excursion + (save-restriction + (org-narrow-to-subtree) + (goto-char (point-min)) + (when (re-search-forward "^\\s-*:PROPERTIES:" nil t) + (org-hide-drawer-toggle))))) + +(defun my-org-open-default-notes-file () + (interactive) + (find-file org-default-notes-file)) + +;; links +(defun my-org-substitute-gnus-link-after-archiving () + "Fix a captured gnus article link after they've been archived" + (interactive) + (when (org-in-regexp org-link-bracket-re) + ;; We do have a link at point, and we are going to edit it. + (save-excursion + (let ((remove (list (match-beginning 0) (match-end 0))) + (desc (when (match-end 2) (match-string-no-properties 2))) + (link (match-string-no-properties 1)) + (target (alist-get 'archive my-gnus-group-default-targets))) + (pcase-dolist (`(,re . ,info) my-gnus-group-alist) + (when (and (string-match re link) + (alist-get 'archive info)) + (setq target (alist-get 'archive info)))) + (setq new-link + (replace-regexp-in-string "/.*?#" (format "/%s#" target) + link)) + (apply #'delete-region remove) + (insert (org-link-make-string new-link desc)) + (sit-for 0))))) + +;; editing heading +(defun my-org-orgzly-merge-link () + "Fixes orgzly entries with links separated from headlines. +Find the first link in the entry, and add that to the headline +title, and remove the body." + (interactive) + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (goto-char (point-min)) + (forward-line) + (when (re-search-forward org-link-any-re) + (let ((link (buffer-substring-no-properties + (match-beginning 0) (match-end 0))) + (unused (replace-match "" nil)) + (desc (org-entry-get (point) "ITEM")) + (title-loc)) + (goto-char (point-min)) + (search-forward desc nil t) + (setq title-loc (match-beginning 0)) + (replace-match "" nil) + (while (search-forward desc nil t) (replace-match "" nil)) + (goto-char title-loc) + (insert (org-link-make-string link desc)))))) + (my-org-node-flush-empty-lines)) + +(defun my-org-node-flush-empty-lines () + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (flush-lines "^$")))) + +(defun my-org-element-contents-at-point () + (let ((element (org-element-at-point))) + (buffer-substring-no-properties + (org-element-property :contents-begin element) + (org-element-property :contents-end element)))) + + +(defun my-org-append-subheading (arg) + "Append a subheading as a first child, or with an arg as a last child." + (interactive "P") + (if arg + (org-insert-subheading '(4)) + (let ((required-level (1+ (or (org-current-level) 0)))) + (org-show-children) + (org-next-visible-heading 1) + (org-insert-subheading nil) + (while (> (org-current-level) required-level) + (org-promote-subtree)) + (while (< (org-current-level) required-level) + (org-demote-subtree))))) + +;; copy a link +;;; fixme: do we still need this? +(defun my-org-copy-link-at-point () + (interactive) + (let ((link (my-org-link-at-point))) + (if link + (progn + (kill-new link) + (message "Copied: %s" link)) + (message "Point is not an org link!")))) + +(defun my-org-link-at-point () + (interactive) + (when (org-in-regexp org-link-any-re) + (org-unbracket-string "<" ">" + (or + ;; [[target][desc]] + (match-string-no-properties 2) + ;; plain link or <...> + (match-string-no-properties 0))))) + +(defun my-org-store-link-and-return () + "run org-goto to select a heading, stores its link and insert it." + (interactive) + (save-restriction + (widen) + (save-excursion + (call-interactively 'org-goto) + (call-interactively 'org-store-link))) + (call-interactively 'org-insert-last-stored-link)) + +;; overload org-insert-all-links (do we need autoload as in the original file?) +(defun my-org-insert-all-links (arg &optional pre post) + "Insert all links in `org-stored-links'. +When a universal prefix, do not delete the links from `org-stored-links'. +When `ARG' is a number, insert the last N link(s). +`PRE' and `POST' are optional arguments to define a string to +prepend or to append." + (interactive "P") + (let ((org-link-keep-stored-after-insertion (equal arg '(4))) + (links (copy-sequence org-stored-links)) + (pr (or pre "- ")) + (po (or post "\n")) + (cnt 1) l) + (if (null org-stored-links) + (message "No link to insert") + (while (and (or (listp arg) (>= arg cnt)) + (setq l (if (listp arg) + (pop links) + (pop org-stored-links)))) + (setq cnt (1+ cnt)) + (insert pr) + (org-insert-link nil (car l) (or (cadr l) "")) + (insert po))))) + +;; overload org-open-at-point-global to fix bug property link not +;; opened in external browser (2d0e61c8-da74-417e-8ccd-c4099ccd88d8) +(defun my-org-open-at-point-global (&optional arg) + "Follow a link or a time-stamp like Org mode does. +Also follow links and emails as seen by `thing-at-point'. +This command can be called in any mode to follow an external +link or a time-stamp that has Org mode syntax. Its behavior +is undefined when called on internal links like fuzzy links. +Raise a user error when there is nothing to follow." + (interactive "P") + (let ((tap-url (thing-at-point 'url)) + (tap-email (thing-at-point 'email))) + (cond ((org-in-regexp org-link-any-re) + (org-link-open-from-string (match-string-no-properties 0) arg)) + ((or (org-in-regexp org-ts-regexp-both nil t) + (org-in-regexp org-tsr-regexp-both nil t)) + (org-follow-timestamp-link)) + (tap-url (org-link-open-from-string tap-url)) + (tap-email (org-link-open-from-string + (concat "mailto:" tap-email))) + (t (user-error "No link found"))))) + +;; overload org-refile-get-targets +(defun my-org-refile-get-targets (&optional default-buffer) + "Produce a table with refile targets." + (let ((case-fold-search nil) + ;; otherwise org confuses "TODO" as a kw and "Todo" as a word + (entries (or org-refile-targets '((nil . (:level . 1))))) + targets tgs files desc descre) + (message "Getting targets...") + (with-current-buffer (or default-buffer (current-buffer)) + (dolist (entry entries) + (setq files (car entry) desc (cdr entry)) + (cond + ((null files) (setq files (list (current-buffer)))) + ((eq files 'org-agenda-files) + (setq files (org-agenda-files 'unrestricted))) + ((and (symbolp files) (fboundp files)) + (setq files (funcall files))) + ((and (symbolp files) (boundp files)) + (setq files (symbol-value files)))) + (when (stringp files) (setq files (list files))) + (cond + ((eq (car desc) :tag) + (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":"))) + ((eq (car desc) :todo) + (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]"))) + ((eq (car desc) :regexp) + (setq descre (cdr desc))) + ((eq (car desc) :level) + (setq descre (concat "^\\*\\{" (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + ((eq (car desc) :maxlevel) + (setq descre (concat "^\\*\\{1," (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + (t (error "Bad refiling target description %s" desc))) + (dolist (f files) + (with-current-buffer (if (bufferp f) f (org-get-agenda-file-buffer f)) + (or + (setq tgs (org-refile-cache-get + (buffer-file-name + (when (bufferp f) (buffer-base-buffer f))) + descre)) + (progn + (when (bufferp f) + (setq f (buffer-file-name (buffer-base-buffer f)))) + (setq f (and f (expand-file-name f))) + (when (eq org-refile-use-outline-path 'file) + (push (list (and f (file-name-nondirectory f)) f nil nil) tgs)) + (when (eq org-refile-use-outline-path 'buffer-name) + (push (list (buffer-name (buffer-base-buffer)) f nil nil) tgs)) + (when (eq org-refile-use-outline-path 'full-file-path) + (push (list (and (buffer-file-name (buffer-base-buffer)) + (file-truename (buffer-file-name (buffer-base-buffer)))) + f nil nil) tgs)) + (org-with-wide-buffer + (goto-char (point-min)) + (setq org-outline-path-cache nil) + (while (re-search-forward descre nil t) + (beginning-of-line) + (let ((case-fold-search nil)) + (looking-at org-complex-heading-regexp)) + (let ((begin (point)) + (heading (match-string-no-properties 4))) + (unless (or (and + org-refile-target-verify-function + (not + (funcall org-refile-target-verify-function))) + (not heading)) + (let ((re (format org-complex-heading-regexp-format + (regexp-quote heading))) + (target + (if (not org-refile-use-outline-path) heading + (mapconcat + #'identity + (append + (pcase org-refile-use-outline-path + (`file (list + (and (buffer-file-name (buffer-base-buffer)) + (file-name-nondirectory + (buffer-file-name (buffer-base-buffer)))))) + (`full-file-path + (list (buffer-file-name + (buffer-base-buffer)))) + (`buffer-name + (list (buffer-name + (buffer-base-buffer)))) + (_ nil)) + (mapcar (lambda (s) (replace-regexp-in-string + "/" "\\/" s nil t)) + (org-get-outline-path t t))) + "/")))) + (push (list target f re (org-refile-marker (point))) + tgs))) + (when (= (point) begin) + ;; Verification function has not moved point. + (end-of-line))))))) + (when org-refile-use-cache + (org-refile-cache-put tgs (buffer-file-name) descre)) + (setq targets (append tgs targets)))))) + (message "Getting targets...done") + (delete-dups (nreverse targets)))) + +;; shadow org-insert-last-stored-link (do not insert \n at the end) +(defun my-org-insert-last-stored-link (arg) + "Insert the last link stored in `org-stored-links'." + (interactive "p") + (org-insert-all-links arg "" "")) + +(defun my-org-info-open-new-window (path) + "Open info in a new buffer" + (my-select-new-window-matching-mode 'Info-mode) + (org-info-follow-link path)) + +(defun my-org-rt-open-new-window (path) + "Open rt in a new buffer" + (my-select-new-window-matching-mode 'rt-liber-browser-mode) + (rt-org-open path)) + +;; fix org src overlay face +(defun my-org-src--make-source-overlay (beg end edit-buffer) + "Create overlay between BEG and END positions and return it. +EDIT-BUFFER is the buffer currently editing area between BEG and +END." + (let ((overlay (make-overlay beg end))) + (overlay-put overlay 'face 'region) + (overlay-put overlay 'edit-buffer edit-buffer) + (overlay-put overlay 'help-echo + "Click with mouse-1 to switch to buffer editing this segment") + (overlay-put overlay 'face 'region) + (overlay-put overlay 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'org-edit-src-continue) + map)) + (let ((read-only + (list + (lambda (&rest _) + (user-error + "Cannot modify an area being edited in a dedicated buffer"))))) + (overlay-put overlay 'modification-hooks read-only) + (overlay-put overlay 'insert-in-front-hooks read-only) + (overlay-put overlay 'insert-behind-hooks read-only)) + overlay)) + +(defun my-org-copy-property-value (name) + (interactive + (list (completing-read "Copy property: " (org-entry-properties)))) + (let ((value (org-entry-get (point) name))) + (kill-new value) + (message "Copied %s" value))) + +(defvar my-org-common-properties nil + "Property list for completion when setting the property of an org node, to + avoid scanning the whole notes.") + +(defun my-org-set-common-property () + (interactive) + (let* ((property + (completing-read "Which property to set: " + my-org-common-properties)) + (value + (org-read-property-value property))) + (org-set-property property value))) + +(defun my-org-copy-src-block-at-point () + (interactive) + (when (org-in-src-block-p) + (kill-new (nth 1 (org-babel-get-src-block-info t))) + (message "org src block copied!"))) +(defun my-org-in-or-at-block-p () + (or (org-at-block-p) + (org-in-block-p '("example" "source" "export" + "center" "quote" "verse")))) +(defun my-org-copy-block-at-point () + (interactive) + (save-excursion + (unless (org-at-block-p) + (org-previous-block 1) + (let ((element (org-element-at-point))) + (kill-new (or + (org-element-property :value element) + (buffer-substring + (org-element-property :contents-begin element) + (org-element-property :contents-end element)))) + (message "org block copied!"))))) + +;; clock save timer doesn't seem to be working +(defun my-org-clock-maybe-save () + (when (equal major-mode 'org-mode) + (org-clock-save))) + +(defun my-org-refile-cache-rebuild () + (org-refile-cache-clear) + (org-refile-get-targets)) + +(defun my-org-store-agenda-view-A () + (interactive) + (org-store-agenda-views) + (my-org-agenda-ensure-A)) + +(defun my-org-agenda-priority-0 () + (interactive) + (org-agenda-priority ?\ )) +(defun my-org-agenda-priority-A () + (interactive) + (org-agenda-priority ?A)) +(defun my-org-agenda-priority-B () + (interactive) + (org-agenda-priority ?B)) +(defun my-org-agenda-priority-C () + (interactive) + (org-agenda-priority ?C)) + +(defun my-org-next-block-or-results (arg &optional backward) + "Jump to the next block or results. + +With a prefix argument ARG, jump forward ARG many blocks. + +When BACKWARD is non-nil, jump to the previous block. + +When BLOCK-REGEXP is non-nil, use this regexp to find blocks. +Match data is set according to this regexp when the function +returns. + +Return point at beginning of the opening line of found block. +Throw an error if no block is found." + (interactive "p") + (let ((re "^[ \t]*#\\+\\(BEGIN\\|RESULTS:\\)") + (case-fold-search t) + (search-fn (if backward #'re-search-backward #'re-search-forward)) + (count (or arg 1)) + (origin (point)) + last-element) + (if backward (beginning-of-line) (end-of-line)) + (while (and (> count 0) (funcall search-fn re nil t)) + (let ((element (save-excursion + (goto-char (match-beginning 0)) + (save-match-data (org-element-at-point))))) + (when (and (memq (org-element-type element) + '(center-block comment-block dynamic-block + example-block export-block quote-block + special-block src-block verse-block fixed-width)) + (<= (match-beginning 0) + (org-element-property :post-affiliated element))) + (setq last-element element) + (cl-decf count)))) + (if (= count 0) + (prog1 (goto-char (org-element-property :post-affiliated last-element)) + (save-match-data (org-show-context))) + (goto-char origin) + (user-error "No %s code blocks" (if backward "previous" "further"))))) + +(defun my-org-previous-block-or-results (arg) + "Jump to the previous block or results. +With a prefix argument ARG, jump backward ARG many source blocks. +When BLOCK-REGEXP is non-nil, use this regexp to find blocks." + (interactive "p") + (my-org-next-block-or-results arg t)) + +;; override org-next-link to include search in any places, including property +;; drawers. +;; TODO: not working yet +;; https://lists.gnu.org/archive/html/emacs-orgmode/2020-01/msg00186.html +(defun my-org-next-link () + (interactive) + (when (org-in-regexp org-any-link-re) + (re-search-forward org-any-link-re nil t)) + (re-search-forward org-any-link-re nil t) + (re-search-backward org-any-link-re nil t) + (when-let ((link (org-element-lineage (org-element-context) '(link) t))) + (goto-char (org-element-property :begin link))) + (when (org-invisible-p) (org-show-context))) + +(defun my-org-previous-link () + (interactive) + (re-search-backward org-any-link-re nil t) + (when-let ((link (org-element-lineage (org-element-context) '(link) t))) + (goto-char (org-element-property :begin link))) + (when (org-invisible-p) (org-show-context))) + +(defun my-org-attach-edit-attached-image () + (interactive) + (start-process + "pinta" nil "/usr/bin/pinta" + (concat (org-attach-dir) "/" + (org-element-property :path (org-element-context))))) + +(defun my-org-capture-place-template-dont-delete-windows (oldfun args) + (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 + (format "\\.\\(%s\\)$" + (string-join + my-org-attach-copy-attached-doc-exts "\\|"))) + +(defun my-org-attach-copy-attached-docs () + (interactive) + (let* ((name + (completing-read "Copy attached docs to: " + my-org-attach-copy-attached-targets)) + (path (alist-get name my-org-attach-copy-attached-targets + nil nil #'equal))) + (let ((basedir (org-attach-dir))) + (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 path) + (copy-file (file-name-concat basedir attached) + (file-name-concat + path + (replace-regexp-in-string ":" "_" attached))) + (message "Done!"))))) + ) + +(defun my-org-attach-all-url-plaintext (arg) + (interactive "P") + (dolist (url (my-org-http-s-links-in-entry)) + (my-org-attach-url-plaintext url))) + +(defun my-org-attach-url-plaintext (url) + (interactive (list (completing-read "Url to fetch: " (my-org-http-s-links-in-entry)))) + (my-org-attach-url-plaintext-internal url current-prefix-arg t)) + +(defun my-org-attach-url-plaintext-all-media (url) + (interactive (list (completing-read "Url to fetch: " + (my-org-http-s-links-in-entry)))) + (my-org-attach-url-plaintext-internal url current-prefix-arg t t)) + +(defun my-org-attach-url (url) + (interactive (list (completing-read "Url to fetch: " + (my-org-http-s-links-in-entry)))) + (let* ((url (my-rewrite-url url)) + (filename (expand-file-name (my-make-filename-from-url url) + (org-attach-dir t)))) + (my-wget-async url filename current-prefix-arg))) + +(defun my-org-attach-url-plaintext-internal (url &optional no-tor move-if-large save-all-media) + (let* ((lynx-buffer (format "*lynx %s*" url)) + (url (my-rewrite-url url)) + (filename (expand-file-name (my-make-filename-from-url url) + (org-attach-dir t))) + (coding-system-for-write 'utf-8)) + (ignore-errors (kill-buffer lynx-buffer)) + (my-touch-new-file filename) + (org-attach-sync) + (set-process-sentinel + (my-start-process-with-torsocks + current-prefix-arg + "org-lynx" lynx-buffer "lynx" "-dump" "--display_charset" "utf-8" url) + (lambda (process event) + (with-current-buffer (process-buffer process) + (goto-char (point-min)) + (write-file filename) + (message "Lynx dumped to: %s" filename) + (when save-all-media + (when-let ((urls (http-s-media-links-in-buffer))) + (message "Downloading %d media files..." (length urls)) + (wget-async-urls-with-prefix + urls (concat filename "-") no-tor move-if-large)))))))) + +;; node creation; start of grok +;; FIXME: decouple clients from org +(defun my-org-create-node (info &optional attach) + (cond ((alist-get "Authors" info nil nil 'string=) + (my-org-create-book-node info attach)) + ((alist-get "Director" info nil nil 'string=) + (my-org-create-video-node info attach)) + ((and (alist-get "Developers" info nil nil 'string=) + (string-match "\\" + (alist-get "Description" info nil nil 'string=))) + (my-org-create-video-game-node info attach)) + ((alist-get "Developers" info nil nil 'string=) + (my-org-create-software-node info attach)) + ((alist-get "Designers" info nil nil 'string=) + (my-org-create-game-node info attach)) + ((alist-get "Founded" info nil nil 'string=) + (my-org-create-organisation-node info attach)) + ((alist-get "Latitude" info nil nil 'string=) + (my-org-create-location-node info attach)) + ((alist-get "Born" info nil nil 'string=) + (my-org-create-people-node info attach)) + (t (my-org-create-entity-node info attach)))) + +(defun my-org-attach-and-add-properties-to-node (info attach) + (when (and attach (alist-get "Cover" info nil nil 'string=)) + (ignore-error 'file-already-exists + (org-attach-url (alist-get "Cover" info nil nil 'string=))) + (setq info (assoc-delete-all "Cover" info 'string=))) + (dolist (pair info) + (when (and (cdr pair) (string> (cdr pair) "")) + (org-entry-put (point) + (decode-coding-string (car pair) 'utf-8) + (decode-coding-string (cdr pair) 'utf-8)))) + (org-entry-put (point) "CREATED" + (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time))) + (org-attach-sync) + (when (buffer-narrowed-p) + (goto-char (point-min)))) + +(defun my-org-create-book-node (book-info attach) + (org-capture nil "book") + (insert (format + "%s - %s - %s" + (or (alist-get "Authors" book-info "" nil 'string=) "") + (alist-get "Title" book-info "" nil 'string=) + (my-extract-year + (alist-get "Published" book-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node book-info attach)) +(defun my-org-create-video-node (video-info attach) + (org-capture nil "video") + (insert (format + "%s - %s - %s" + (alist-get "Director" video-info "" nil 'string=) + (alist-get "Title" video-info "" nil 'string=) + (my-extract-year + (alist-get "Released" video-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node video-info attach)) +(defun my-org-create-location-node (book-info attach) + (org-capture nil "location") + (insert (format + "%s" + (alist-get "Title" book-info "" nil 'string=))) + (my-org-attach-and-add-properties-to-node book-info attach)) +(defun my-org-create-game-node (game-info attach) + (org-capture nil "game") + (insert (format + "%s - %s - %s" + (alist-get "Designers" game-info "" nil 'string=) + (alist-get "Title" game-info "" nil 'string=) + (my-extract-year + (alist-get "Published" game-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node game-info attach)) +(defun my-org-create-video-game-node (game-info attach) + (org-capture nil "videogame") + (insert (format + "%s - %s - %s" + (alist-get "Developers" game-info "" nil 'string=) + (alist-get "Title" game-info "" nil 'string=) + (my-extract-year + (alist-get "Released" game-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node game-info attach)) +(defun my-org-create-software-node (software-info attach) + (org-capture nil "software") + (insert (format + "%s - %s" + (alist-get "Title" software-info "" nil 'string=) + (my-extract-year + (alist-get "Released" software-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node software-info attach)) +(defun my-org-create-organisation-node (organisation-info attach) + (org-capture nil "organisation") + (insert (format + "%s - %s" + (alist-get "Title" organisation-info "" nil 'string=) + (my-extract-year + (alist-get "Founded" organisation-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node organisation-info attach)) +(defun my-org-create-people-node (people-info attach) + (org-capture nil "people") + (insert (format + "%s - %s-%s" + (alist-get "Title" people-info "" nil 'string=) + (my-extract-year (alist-get "Born" people-info "" nil 'string=)) + (my-extract-year (alist-get "Died" people-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node people-info attach)) +(defun my-org-create-pacman-software-node (package) + (interactive "sPacman package name: ") + (my-org-create-software-node (my-grok-pacman package) nil)) +(defun my-org-create-entity-node (entity-info attach) + (org-capture nil "entity") + (insert (format + "%s" + (alist-get "Title" entity-info "" nil 'string=))) + (my-org-attach-and-add-properties-to-node entity-info attach)) +(defun my-org-create-audio-node (audio-info attach) + (org-capture nil "ya") + (insert (format + "%s - %s - %s" + (or (alist-get "Authors" audio-info "" nil 'string=) "") + (alist-get "Title" audio-info "" nil 'string=) + (my-extract-year + (alist-get "Published" audio-info "" nil 'string=)))) + (my-org-attach-and-add-properties-to-node audio-info attach)) + +;; TODO: these requires are unnecessary for more essential functionalities of +;; org customisation. Find a way to delay them +(require 'my-wikipedia) +(require 'my-github) +(require 'my-gitlab) +(require 'my-pacman) +(require 'my-openlibrary) +(defun my-grok-dispatcher (url) + (when-let ((host (url-host (url-generic-parse-url url)))) + (cond ((string-match "wikipedia\\.org" host) 'my-grok-wikipedia) + ((string-match "github\\.com" host) 'my-grok-github) + ((string-match "\\(gitlab\\.\\|salsa.debian.org\\)" host) + 'my-grok-gitlab) + ((string-match "openlibrary.org" host) 'my-grok-openlibrary) + (t nil)))) +(defun my-grok-update-properties () + (interactive) + (when-let* ((url (org-entry-get (point) "Source")) + (source-dispatcher (my-grok-dispatcher url))) + (my-org-attach-and-add-properties-to-node + (funcall source-dispatcher url) t)) + (when-let ((isbn (org-entry-get (point) "ISBN"))) + (my-org-attach-and-add-properties-to-node (my-grok-openlibrary-isbn isbn) t)) + (when-let ((url (org-entry-get (point) "OpenLibrary-link"))) + (my-org-attach-and-add-properties-to-node (my-grok-openlibrary url) t)) + (when-let ((package (org-entry-get (point) "Pacman-package-name"))) + (my-org-attach-and-add-properties-to-node (my-grok-pacman package) nil)) + (when-let ((url (org-entry-get (point) "Wikipedia-link"))) + (my-org-attach-and-add-properties-to-node (my-grok-wikipedia url) t))) +(defun my-org-protocol-grok (data) + (when-let ((url (plist-get data :url))) + (my-org-grok url)) + nil) + +(defun my-org-grok (url) + (when-let* ((grok-fun (my-grok-dispatcher url)) + (info (funcall grok-fun url))) + (my-org-create-node info t))) + +(defun my-eww-org-protocol-grok () + "grok from eww" + (interactive) + (org-protocol-grok + (list :url (plist-get eww-data :url)))) + +;; org capture rss +(defun my-org-rss-xml-create-audio-node (url) + (interactive (list (read-string "Feed URL: " + (thing-at-point-url-at-point)))) + (my-org-rss-xml-create-node url 'my-org-create-audio-node)) +(defun my-org-rss-xml-create-book-node (url) + (interactive (list (read-string "Feed URL: " + (thing-at-point-url-at-point)))) + (my-org-rss-xml-create-node url 'my-org-create-book-node)) +(defun my-org-rss-xml-create-node (url create-node-fun) + (let* ((xml + (with-current-buffer (url-retrieve-synchronously url) + (my-skip-http-header) + (car (xml-parse-region (point) (point-max))))) + (channel (my-xml-get-first-child xml 'channel)) + ) + (funcall create-node-fun + (list + (cons "Feed-url" url) + (cons "Title" (decode-coding-string + (my-xml-get-first-child-text channel 'title) 'utf-8)) + (cons "Description" + (decode-coding-string + (my-xml-get-first-child-text channel 'description) 'utf-8)) + (cons "Website" (my-xml-get-first-child-text channel 'link)) + (cons "Cover" + (or (my-xml-get-first-child-text + (my-xml-get-first-child channel 'image) 'url) + (dom-attr + (my-xml-get-first-child channel 'itunes:image) 'href))) + (cons "Authors" (my-xml-get-first-child-text + channel 'itunes:author))) + t))) + +(require 'my-algo) +(defun my-radix-org-from-tree (tree) + (let ((radix-tree-type 'vector)) + (radix-tree-iter-subtrees + tree + (my-radix-org-iter-n 1 [])))) + +(defun my-radix-org-iter-n (depth prefix) + (lambda (p s) + (let ((nprefix (seq-concatenate radix-tree-type prefix p))) + (insert (make-string depth ?*) " ") + (pcase s + ((radix-tree-leaf v) (insert "[[" (string-join nprefix "/") "][" (string-join p "/") "]]" "\n")) + (_ + (insert (string-join p "/") "\n") + (radix-tree-iter-subtrees s (my-radix-org-iter-n (1+ depth) nprefix))))))) + +(defun my-radix-org () + (interactive) + (let* ((file-name (buffer-file-name)) + (buffer-name (file-name-with-extension + (file-name-base file-name) + "org")) + (save-file-name (file-name-with-extension file-name "org")) + (tree (let ((max-lisp-eval-depth 32000)) + (save-excursion (my-radix-tree-from-list))))) + (with-current-buffer (get-buffer-create buffer-name) + (org-mode) + (erase-buffer) + (my-radix-org-from-tree tree) + (goto-char (point-min))) + (switch-to-buffer buffer-name))) + +;;; format org mode elements +(defun my-org-format-link (url text) + (format "[[%s][%s]]" url text)) + +(defun my-org-format-heading (text level) + (format "%s %s" + (make-string level ?*) text)) + +(defun my-org-update-updated () + (interactive) + (when (derived-mode-p 'org-mode) + (org-entry-put + (point) "UPDATED" + (format-time-string "[%Y-%m-%d %a %H:%M]" (current-time))))) + +;;; override org-recoll-format-results +(defun my-org-recoll-format-results () + (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 "" (substring my-docs-root-dir 1)) + "(\\1)") + (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)) + +(defun my-org-recoll-mdn (query) + (interactive "sSearch mdn: ") + (org-recoll-search (format "%s dir:mdn" query))) + +(defun my-org-recoll-python (query) + (interactive "sSearch python: ") + (org-recoll-search (format "%s dir:python-3.9.7-docs-html" query))) + +(defun my-org-recoll-php (query) + (interactive "sSearch php: ") + (org-recoll-search (format "%s dir:php-chunked-xhtml" query))) + +(defun my-org-recoll-yesod (query) + (interactive "sSearch yesod: ") + (org-recoll-search (format "%s dir:yesod-cookbook OR dir:yesodweb.com" query))) + +(defun my-org-entry-at-point-to-tsv (id) + (string-join + (cons (number-to-string id) + (mapcar + (lambda (key) (org-entry-get (point) key)) + (list "ITEM" "Referral" "Wikipedia-link" "IMDB-link"))) + "\t")) + +(defvar org-entries-tsv-buffer "*org-entries-tsv*") +(defun my-org-entries-at-point-to-tsv (beg end) + (interactive "r") + (with-current-buffer (get-buffer-create org-entries-tsv-buffer) + (erase-buffer)) + (let ((row) (id 0)) + (save-excursion + (goto-char beg) + (while (< (point) end) + (when (equal (org-entry-get (point) "TODO") "TODO") + (setq row (my-org-entry-at-point-to-tsv id)) + (with-current-buffer org-entries-tsv-buffer + (insert row "\n")) + (setq id (1+ id))) + (org-next-visible-heading 1)))) + (switch-to-buffer-other-window org-entries-tsv-buffer)) + +(defun my-org-entries-attach-plaintext-all-media (beg end) + (interactive "r") + (save-excursion + (goto-char beg) + (while (< (point) end) + (my-org-attach-url-plaintext-all-media (car (my-org-http-s-links-in-entry))) + (org-next-visible-heading 1)))) + +(defvar my-org-doc-dir nil "Directory to docs written in org.") +(defun my-org-open-org-doc (filename) + (interactive + (list + (completing-read + "Open org doc: " + (mapcar (lambda (name) (substring name (length my-org-doc-dir))) + (directory-files-recursively my-org-doc-dir "\\.org$"))))) + (find-file (concat my-org-doc-dir filename))) + +(defun my-org-open-org-file (filename) + (interactive + (list + (completing-read + "Open org file: " + (directory-files org-directory nil "\\.org$")))) + (find-file (file-name-concat org-directory filename))) + +(defun my-org-agenda-after-show () (beginning-of-line 1)) + +(defun my-org-agenda-ensure-A () + (org-agenda nil "A") + (unless (get-text-property (point) 'org-series-redo-cmd) + (kill-buffer) + (org-agenda nil "A"))) + +(defun my-org-agenda-redo-all () + (interactive) + (message "time now is %s" + (format-time-string "%Y-%m-%d %a %H:%M:%S" (current-time))) + (my-org-agenda-ensure-A) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (derived-mode-p 'org-agenda-mode) + (print buffer) + (org-agenda-redo t))))) + +(defun my-org-copy-dwim () + (interactive) + (cond ((org-in-src-block-p) + (my-org-copy-src-block-at-point)) + ((my-org-in-or-at-block-p) (my-org-copy-block-at-point)) + (t (org-refile-copy)))) + +;; to override `org--mouse-open-at-point' - we don't want +;; `org-open-at-point' to toggle a checkbox when point is at the +;; beginning of a link +(defun my-org--mouse-open-at-point (orig-fun &rest args) + (let ((context (org-context))) + (cond + ((assq :headline-stars context) (org-cycle)) + ((assq :item-bullet context) + (let ((org-cycle-include-plain-lists t)) (org-cycle))) + ((org-footnote-at-reference-p) nil) + (t (apply orig-fun args))))) + +(provide 'my-org) +;;; my-org.el ends here -- cgit v1.2.3