Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
46 lines (44 sloc) 1.79 KB
;;
;; Archive subtrees under the same hierarchy as the original org file.
;; Link: https://gist.github.com/Fuco1/e86fb5e0a5bb71ceafccedb5ca22fcfb
;;
(require 'dash)
(defadvice org-archive-subtree (around fix-hierarchy activate)
(let* ((fix-archive-p (and (not current-prefix-arg)
(not (use-region-p))))
(afile (car (org-archive--compute-location
(or (org-entry-get nil "ARCHIVE" 'inherit) org-archive-location))))
(buffer (or (find-buffer-visiting afile) (find-file-noselect afile))))
ad-do-it
(when fix-archive-p
(with-current-buffer buffer
(goto-char (point-max))
(while (org-up-heading-safe))
(let* ((olpath (org-entry-get (point) "ARCHIVE_OLPATH"))
(path (and olpath (split-string olpath "/")))
(level 1)
tree-text)
(when olpath
(org-mark-subtree)
(setq tree-text (buffer-substring (region-beginning) (region-end)))
(let (this-command) (org-cut-subtree))
(goto-char (point-min))
(save-restriction
(widen)
(-each path
(lambda (heading)
(if (re-search-forward
(rx-to-string
`(: bol (repeat ,level "*") (1+ " ") ,heading)) nil t)
(org-narrow-to-subtree)
(goto-char (point-max))
(unless (looking-at "^")
(insert "\n"))
(insert (make-string level ?*)
" "
heading
"\n"))
(cl-incf level)))
(widen)
(org-end-of-subtree t t)
(org-paste-subtree level tree-text))))))))
You can’t perform that action at this time.