Skip to content

Instantly share code, notes, and snippets.

@mskorzhinskiy
Created July 13, 2021 19:09
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save mskorzhinskiy/98fcbec6409b18444027a4842066a08f to your computer and use it in GitHub Desktop.
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
;; 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