Last active
October 1, 2023 19:30
-
-
Save edgimar/072d99d8650abe81a9fe7c8687c0c993 to your computer and use it in GitHub Desktop.
Org-mode archive function that includes ancestor tree structure when copying
This file contains 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
(require 'org-archive) | |
; Set the function to use for org-archive-default (C-c C-x C-a) | |
; (setq org-archive-location (concat org-directory "/archive/%s_archive::")) | |
; (setq org-archive-location "archive/archived_%s::") | |
(setq org-archive-location "::* ARCHIVED") | |
; unmap org-archive-subtree | |
(define-key org-mode-map (kbd "C-c C-x C-s") nil) | |
; select command to execute via org-archive-subtree-default (C-c C-x C-a) | |
(setq org-archive-default-command 'org-archive-subtree-hierarchical) | |
(defun line-content-as-string () | |
"Returns the content of the current line as a string" | |
(save-excursion | |
(beginning-of-line) | |
(buffer-substring-no-properties | |
(line-beginning-position) (line-end-position)))) | |
(defun org-child-list (&optional top-level) | |
"This function returns all children of a heading as a list. " | |
(interactive) | |
(save-excursion | |
;; this only works with org-version > 8.0, since in previous | |
;; org-mode versions the function (org-outline-level) returns | |
;; gargabe when the point is not on a heading. | |
(unless top-level | |
(if (= (org-outline-level) 0) | |
(outline-next-visible-heading 1) | |
(org-goto-first-child))) | |
(let ((child-list (list (line-content-as-string)))) | |
(while (org-goto-sibling) | |
(setq child-list (cons (line-content-as-string) child-list))) | |
child-list))) | |
(defun fa/org-struct-subtree () | |
"This function returns the tree structure in which a subtree belongs as a list." | |
(interactive) | |
(let ((archive-tree nil)) | |
(save-excursion | |
(while (org-up-heading-safe) | |
(let ((heading | |
(buffer-substring-no-properties | |
(line-beginning-position) (line-end-position)))) | |
(if (eq archive-tree nil) | |
(setq archive-tree (list heading)) | |
(setq archive-tree (cons heading archive-tree)))))) | |
archive-tree)) | |
(defun org-archive-subtree-hierarchical () | |
"This function archives a subtree hierarchical" | |
(interactive) | |
(let ((org-tree (fa/org-struct-subtree)) | |
(source-buffer (current-buffer)) | |
(file (abbreviate-file-name | |
(or (buffer-file-name (buffer-base-buffer)) | |
(error "No file associated to buffer"))))) | |
(save-excursion | |
(setq location (org-archive--compute-location | |
(or (org-entry-get nil "ARCHIVE" 'inherit) | |
org-archive-location)) | |
afile (car location) | |
heading (cdr location) | |
infile-p (equal file (abbreviate-file-name (or afile "")))) | |
(unless afile | |
(error "Invalid `org-archive-location'")) | |
(if (not (equal heading "")) | |
(progn | |
(setq org-tree (cons heading | |
(mapcar (lambda (s) (concat "*" s)) org-tree))) | |
(org-demote-subtree))) | |
(if (> (length afile) 0) | |
(progn | |
(setq newfile-p (not (file-exists-p afile)) | |
visiting (find-buffer-visiting afile) | |
target-buffer (or visiting (find-file-noselect afile)))) | |
(progn | |
(setq target-buffer (current-buffer)))) | |
(unless target-buffer | |
(error "Cannot access file \"%s\"" afile)) | |
(org-cut-subtree) | |
(set-buffer target-buffer) | |
(setq ind-target-buffer (clone-indirect-buffer nil nil)) | |
(set-buffer ind-target-buffer) | |
(org-mode) | |
(goto-char (point-min)) | |
; simplified version of org-complex-heading-regexp-format | |
(setq my-org-complex-heading-regexp-format | |
(concat "^" | |
"\\(%s\\)" | |
"\\(?: *\\[[0-9%%/]+\\]\\)*" | |
"\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?" | |
"[ \t]*$")) | |
(setq top-level-p t) | |
(while (not (equal org-tree nil)) | |
(let ((child-list (org-child-list top-level-p)) | |
(re (format my-org-complex-heading-regexp-format (regexp-quote (car org-tree)))) | |
) | |
(if (member "______FOUND_MATCH" (mapcar (lambda (s) (replace-regexp-in-string re "______FOUND_MATCH" s)) child-list)) | |
(progn | |
(re-search-forward re nil t) | |
(setq org-tree (cdr org-tree))) | |
(progn | |
(if (not top-level-p) (newline)) | |
(org-insert-struct org-tree) | |
(setq org-tree nil)))) | |
(setq top-level-p nil)) | |
(newline) | |
(org-yank) | |
;; Kill the indirect buffer, returning the current buffer to the direct target buffer | |
(kill-buffer ind-target-buffer) | |
;; Save and kill the target buffer, if it is not the source buffer. | |
(when (not (eq source-buffer target-buffer)) | |
(save-buffer target-buffer) | |
(kill-buffer target-buffer)) | |
;; ensure font-lock and indentation are normal | |
(set-buffer source-buffer) | |
(org-restart-font-lock) | |
(org-indent-mode t) | |
(message "Subtree archived %s" | |
(concat "in file: " (abbreviate-file-name afile)))))) | |
(defun org-insert-struct (struct) | |
"TODO" | |
(interactive) | |
(when struct | |
(insert (car struct)) | |
(if (not (equal (length struct) 1)) | |
(newline)) | |
(org-insert-struct (cdr struct)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
I was planning to update it, but I simply stopped using the archive function. Precisely because there's no native way to use this functionality. I must say that I found the org-mode codebase to be hard to understand in many ways.