Re: Smart archiving of subtrees with parent headlines

[Mark Edgington <edgimar@gmail.com>]

On Mon, Feb 12, 2018 at 1:54 AM, Ken Mankoff <mankoff@gmail.com> wrote:
>
> Does the attached file here work for you? I use it and it seems to do what you describe.
>
> https://lists.gnu.org/archive/html/emacs-orgmode/2014-08/msg00109.html
>

Ken, I tried the code you included from your config file, and while it does
satisfy my requirement 2 (the subtree will be merged into an existing path
under the target if an appropriate path already exists), the first requirement
of it being moved to be "beneath" a specified target location seems not to be
working correctly.

I've modified your code so that it can at least handle archiving subtrees
beneath a specified target headline.  The new code assumes that the specified
target headline is at level 1 (has a single asterisk), but it would be nice if
this could be made to work with a target headline having a larger depth.  Note
that I changed the behavior from what you had so that hierarchical archiving is
used whether or not the target is in the current buffer.

Although archiving is a bit less painful for me now with this new code, there
are still a few things it would be nice to have:

 - arbitrary-depth target-headline
 - option to prefix target-headline with source filename (this probably won't take too much work)
 - option to add archival properties to each archived item (e.g. date archived)


Here's a diff from the code you posted:

--- old 2018-02-12 10:14:07.646226775 -0500
+++ new 2018-02-12 14:51:20.676703024 -0500
@@ -1,18 +1,11 @@
-(setq org-archive-location (concat org-directory "/archive/%s_archive::"))
+; (setq org-archive-location (concat org-directory "/archive/%s_archive::"))
+(setq org-archive-location "archive/archived_%s::")
 
+; unmap org-archive-subtree
 (define-key org-mode-map (kbd "C-c C-x C-s") nil)
-(setq org-archive-default-command 'kdm/org-archive-local-or-hierarchical) ;; C-c C-x C-a
 
-;; only do hierarchical archiving if default var used. If archiving into
-;; local file, then just use default org-archive-subtree command
-(defun kdm/org-archive-local-or-hierarchical ()
-  "Archive locally if location set to local file; Otherwise use org-archive-subtree-hierarchical"
-  (interactive)
-  (if (let ((arch-file (org-extract-archive-file))
-            (this-file (buffer-file-name)))
-           (equal arch-file this-file))
-  (org-archive-subtree)
-  (org-archive-subtree-hierarchical)))
+; select command to execute via org-archive-subtree-default (C-c C-x C-a)
+(setq org-archive-default-command 'org-archive-subtree-hierarchical)
 
 (require 'org-archive)
 
@@ -23,16 +16,17 @@
     (buffer-substring-no-properties
      (line-beginning-position) (line-end-position))))
 
-(defun org-child-list ()
+(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.
-    (if (= (org-outline-level) 0)
-        (outline-next-visible-heading 1)
-      (org-goto-first-child))
+    (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)))
@@ -68,6 +62,11 @@
             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)
           (setq newfile-p (not (file-exists-p afile))
                 visiting (find-buffer-visiting afile)
@@ -79,16 +78,18 @@
       (set-buffer buffer)
       (org-mode)
       (goto-char (point-min))
+      (setq top-level-p t)
       (while (not (equal org-tree nil))
-        (let ((child-list (org-child-list)))
+        (let ((child-list (org-child-list top-level-p)))
           (if (member (car org-tree) child-list)
               (progn
-                (search-forward (car org-tree) nil t)
+                (re-search-forward (concat "^" (regexp-quote (car org-tree))) nil t)
                 (setq org-tree (cdr org-tree)))
             (progn
-              (newline)
+              (if (not top-level-p) (newline))
               (org-insert-struct org-tree)
-              (setq org-tree nil)))))
+              (setq org-tree nil))))
+        (setq top-level-p nil))
       (newline)
       (org-yank)
       ;; Save and kill the buffer, if it is not the same buffer.
@@ -103,5 +104,6 @@
   (interactive)
   (when struct
     (insert (car struct))
-    (newline)
+    (if  (not (equal (length struct) 1))
+        (newline))
     (org-insert-struct (cdr struct))))