Created
July 13, 2021 19:09
-
-
Save mskorzhinskiy/98fcbec6409b18444027a4842066a08f to your computer and use it in GitHub Desktop.
My approach to make readable IDs in org-mode and make sensible directory names in org-attach folders
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
;; Taken from https://github.com/novoid/dot-emacs/blob/master/config.org | |
(defun my-generate-sanitized-alnum-dash-string (str) | |
"Returns a string which contains only a-zA-Z0-9 with single dashes | |
replacing all other characters in-between them. | |
Some parts were copied and adapted from org-hugo-slug | |
from https://github.com/kaushalmodi/ox-hugo (GPLv3)." | |
(let* (;; Remove "<FOO>..</FOO>" HTML tags if present. | |
(str (replace-regexp-in-string "<\\(?1:[a-z]+\\)[^>]*>.*</\\1>" "" str)) | |
;; Remove org-mode links | |
(str (replace-regexp-in-string "\\[\\[.*\\]\\[" "" str)) | |
;; Remove URLs if present in the string. The ")" in the | |
;; below regexp is the closing parenthesis of a Markdown | |
;; link: [Desc](Link). | |
(str (replace-regexp-in-string (concat "\\](" ffap-url-regexp "[^)]+)") "]" str)) | |
;; Replace "&" with " and ", "." with " dot ", "+" with | |
;; " plus ". | |
(str (replace-regexp-in-string | |
"&" " and " | |
(replace-regexp-in-string | |
"\\." " dot " | |
(replace-regexp-in-string | |
"\\+" " plus " str)))) | |
;; Replace German Umlauts with 7-bit ASCII. | |
(str (replace-regexp-in-string "[Ä]" "Ae" str t)) | |
(str (replace-regexp-in-string "[Ü]" "Ue" str t)) | |
(str (replace-regexp-in-string "[Ö]" "Oe" str t)) | |
(str (replace-regexp-in-string "[ä]" "ae" str t)) | |
(str (replace-regexp-in-string "[ü]" "ue" str t)) | |
(str (replace-regexp-in-string "[ö]" "oe" str t)) | |
(str (replace-regexp-in-string "[ß]" "ss" str t)) | |
;; Replace all characters except alphabets, numbers and | |
;; parentheses with spaces. | |
(str (replace-regexp-in-string "[^[:alnum:]()]" " " str)) | |
;; On emacs 24.5, multibyte punctuation characters like ":" | |
;; are considered as alphanumeric characters! Below evals to | |
;; non-nil on emacs 24.5: | |
;; (string-match-p "[[:alnum:]]+" ":") | |
;; So replace them with space manually.. | |
(str (if (version< emacs-version "25.0") | |
(let ((multibyte-punctuations-str ":")) ;String of multibyte punctuation chars | |
(replace-regexp-in-string (format "[%s]" multibyte-punctuations-str) " " str)) | |
str)) | |
;; Remove leading and trailing whitespace. | |
(str (replace-regexp-in-string "\\(^[[:space:]]*\\|[[:space:]]*$\\)" "" str)) | |
;; Replace 2 or more spaces with a single space. | |
(str (replace-regexp-in-string "[[:space:]]\\{2,\\}" " " str)) | |
;; Replace parentheses with double-hyphens. | |
(str (replace-regexp-in-string "\\s-*([[:space:]]*\\([^)]+?\\)[[:space:]]*)\\s-*" " -\\1- " str)) | |
;; Remove any remaining parentheses character. | |
(str (replace-regexp-in-string "[()]" "" str)) | |
;; Replace spaces with hyphens. | |
(str (replace-regexp-in-string " " "-" str)) | |
;; Remove leading and trailing hyphens. | |
(str (replace-regexp-in-string "\\(^[-]*\\|[-]*$\\)" "" str))) | |
str)) | |
(defun org-id-new-as-outline (&optional prefix) | |
"Returns the ID property if set or generates and returns a new one if not set. | |
The generated ID is stripped off potential progress indicator cookies and | |
sanitized to get a slug. Furthermore, it is prepended with an ISO date-stamp | |
if none was found before." | |
(interactive) | |
(let* ((title (get-title (buffer-file-name (or (buffer-base-buffer (current-buffer)) | |
(current-buffer))))) | |
(title (my-generate-sanitized-alnum-dash-string title)) | |
(previous-headlines | |
(let (acc) | |
(dolist (h (org-get-outline-path nil nil)) | |
(setq acc (concat acc (let ((pos (or (string-match "[:alnum:а-яА-Я]" h) | |
0))) | |
(substring h pos (1+ pos)))))) | |
acc)) | |
(headline (nth 4 (org-heading-components))) | |
(headline (my-generate-sanitized-alnum-dash-string headline)) | |
(headline (substring headline 0 (min 60 (length headline)))) | |
(headline (replace-regexp-in-string "[-]+$" "" headline)) | |
(date (or (when-let ((date-prop | |
(or (org-entry-get (point) "Created") | |
(org-entry-get (point) "CLOSED") | |
(org-entry-get (point) "SCHEDULED")))) | |
(ts-format "%Y.%m.%d" (ts-parse date-prop))) | |
(let* ((now (format-time-string "%Y.%m.%d")) | |
(created-prop (format-time-string "[%Y-%m-%d %a]"))) | |
(org-set-property "Created" created-prop) | |
now))) | |
(headline-date | |
(mapconcat 'identity (list date | |
headline | |
previous-headlines) "--")) | |
(my-generate-sanitized-alnum-dash-string headline-date)) | |
(mapconcat 'identity (list title headline-date) "/"))) | |
(defvar org-id-outline-method t) | |
(defun org-id-new-advice (func &rest args) | |
"???" | |
(if org-id-outline-method | |
(apply #'org-id-new-as-outline args) | |
(apply func args))) | |
(after! org | |
(advice-add #'org-id-new :around #'org-id-new-advice) | |
(setq org-attach-id-to-path-function-list '(capitlise-and-add-spaces))) | |
(defun capitlise-and-add-spaces (id) | |
(let* ((id (replace-regexp-in-string (regexp-quote "-") " " id nil 'literal)) | |
(id (capitalize id))) | |
id)) | |
(defun org-attach-id-my-id (id) | |
"TBD" | |
(let* ((id (replace-regexp-in-string (regexp-quote "--") "/" id nil 'literal)) | |
(id (replace-regexp-in-string (regexp-quote "-") " " id nil 'literal)) | |
(id (capitalize id))) | |
id)) | |
(defun update-ids-everywhere () | |
(interactive) | |
(let ((headlines-with-ids (org-ql-select (org-agenda-files) | |
'(property "ID") | |
:action #'element-with-markers))) | |
(dolist (entry headlines-with-ids) | |
(org-with-point-at (plist-get (cadr entry) :org-marker) | |
(condition-case nil | |
(reattach-with-new-id-method) | |
(message (format "Failed reattaching for '%s'" (org-get-heading)))))))) | |
(defun reattach-with-new-id-method () | |
(interactive) | |
(message (format ">> %s" (org-entry-get (point) "ID"))) | |
(let ((new-id (org-id-new)) | |
(current-path (let ((org-attach-id-to-path-function-list | |
'(capitlise-and-add-spaces))) | |
(org-attach-dir)))) | |
(org-delete-property "ID") | |
(org-set-property "ID" new-id) | |
(when current-path | |
(let* ((new-path (org-attach-dir t t)) | |
(files (directory-files current-path t directory-files-no-dot-files-regexp)) | |
(args (list "mv" nil 0 nil)) | |
(args (append args files)) | |
(args (append args (list new-path)))) | |
(when (not (string= current-path | |
new-path)) | |
(apply #'call-process args)))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment