[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [O] Smart archiving of subtrees with parent headlines
From: |
Mark Edgington |
Subject: |
Re: [O] Smart archiving of subtrees with parent headlines |
Date: |
Mon, 12 Feb 2018 16:06:00 -0500 |
User-agent: |
Mutt/1.5.24 (2015-08-30) |
On Mon, Feb 12, 2018 at 1:54 AM, Ken Mankoff <address@hidden> 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))))