Instantly share code, notes, and snippets.

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"
(line-beginning-position) (line-end-position))))
(defun org-child-list (&optional top-level)
"This function returns all children of a heading as a list. "
;; 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)
(let ((child-list (list (line-content-as-string))))
(while (org-goto-sibling)
(setq child-list (cons (line-content-as-string) child-list)))
(defun fa/org-struct-subtree ()
"This function returns the tree structure in which a subtree
belongs as a list."
(let ((archive-tree nil))
(while (org-up-heading-safe)
(let ((heading
(line-beginning-position) (line-end-position))))
(if (eq archive-tree nil)
(setq archive-tree (list heading))
(setq archive-tree (cons heading archive-tree))))))
(defun org-archive-subtree-hierarchical ()
"This function archives a subtree hierarchical"
(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")))))
(setq location (org-get-local-archive-location)
afile (org-extract-archive-file location)
heading (org-extract-archive-heading location)
infile-p (equal file (abbreviate-file-name (or afile ""))))
(unless afile
(error "Invalid `org-archive-location'"))
(if (not (equal heading ""))
(setq org-tree (cons heading
(mapcar (lambda (s) (concat "*" s)) org-tree)))
(if (> (length afile) 0)
(setq newfile-p (not (file-exists-p afile))
visiting (find-buffer-visiting afile)
target-buffer (or visiting (find-file-noselect afile))))
(setq target-buffer (current-buffer))))
(unless target-buffer
(error "Cannot access file \"%s\"" afile))
(set-buffer target-buffer)
(setq ind-target-buffer (clone-indirect-buffer nil nil))
(set-buffer ind-target-buffer)
(goto-char (point-min))
; simplified version of org-complex-heading-regexp-format
(setq my-org-complex-heading-regexp-format
(concat "^"
"\\(?: *\\[[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))
(re-search-forward re nil t)
(setq org-tree (cdr org-tree)))
(if (not top-level-p) (newline))
(org-insert-struct org-tree)
(setq org-tree nil))))
(setq top-level-p nil))
;; 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-indent-mode t)
(message "Subtree archived %s"
(concat "in file: " (abbreviate-file-name afile))))))
(defun org-insert-struct (struct)
(when struct
(insert (car struct))
(if (not (equal (length struct) 1))
(org-insert-struct (cdr struct))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment