Archive subtrees under the same hierarchy as original in the archive files

The way archiving works in org-mode always annoyed me. Specifically the fact that the tree structure gets flattened when you archive your tasks. Sure, there is the property ARCHIVE_OLPATH but it is not as visual as having the tasks in trees. Plus it makes things like clock reports very difficult.

If your tree equals a project, clockreport with C-c C-x C-r will sum the times properly… well not anymore with flattened structure. This works so long as you archive the entire project at once, but I often have projects so huge (e.g. Emacs Configuration) that I archive subtress or parts or just single tasks on a regular basis, with the base project being practically never-ending.

Well, no more, I said, and wrote this handy advice that uses the aforementioned property to reconstruct the tree in the archive file. If the parent headings don't exist they are created on-demand. There is one caveat: if you have non-unique headings, this can sometimes file things under wrong tree; the search is done from top to bottom following the hierarchy.

(defadvice org-archive-subtree (around fix-hierarchy activate)
  (let* ((fix-archive-p (and (not current-prefix-arg)
                             (not (use-region-p))))
         (afile (org-extract-archive-file (org-get-local-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))))))))

The code uses the old advice system because I like it better (it reads much better, even if it isn't so powerful), plus I still use Emacs 24. If you test this on new versions and find out it doesn't work, open an issue or a pull request. It also depends on dash.el so make sure you have that installed.