From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mark Edgington Subject: Re: Smart archiving of subtrees with parent headlines Date: Mon, 12 Feb 2018 16:06:00 -0500 Message-ID: <20180212210600.GB6756@waldo4> References: Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:45901) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1elLId-0003AH-JE for emacs-orgmode@gnu.org; Mon, 12 Feb 2018 16:06:08 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1elLIa-00045q-A9 for emacs-orgmode@gnu.org; Mon, 12 Feb 2018 16:06:07 -0500 Received: from mail-it0-x230.google.com ([2607:f8b0:4001:c0b::230]:54016) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1elLIa-00045F-1V for emacs-orgmode@gnu.org; Mon, 12 Feb 2018 16:06:04 -0500 Received: by mail-it0-x230.google.com with SMTP id i144so8444412ita.3 for ; Mon, 12 Feb 2018 13:06:03 -0800 (PST) Content-Disposition: inline In-Reply-To: List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: "Emacs-orgmode" To: Ken Mankoff Cc: emacs-orgmode On Mon, Feb 12, 2018 at 1:54 AM, Ken Mankoff 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))))