Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Org-mode archive function that includes ancestor tree structure when copying
(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))))
@notetiene
Copy link

notetiene commented Apr 15, 2022

The org-archive-subtree-hierarchical function should be updated to use local (let) binding instead of leaking in the global scope (using setq). This is really bad practice.

Also, I see several redundant constructs. Why using progn in if instead of using the when structure? For what purpose is the infile-p variable?

@edgimar
Copy link
Author

edgimar commented Apr 19, 2022

feel free to post your suggested (and tested!) version as a gist or on a pasteboard, and I'll update it. On the other hand, this could be turned into a regular repository if that makes things easier. Ideally it could at some point get merged into org or org-contrib.

@notetiene
Copy link

notetiene commented Apr 22, 2022

I was thinking exactly the same thing. Why it's not even in org-mode by default. The only thing preventing including the modified form would be copyright assignment. I've seen numerous variations of this gist. It looks like the whole community made it.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment