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)))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment