emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
* [PATCH] org: Support creating arbitrary headline paths when refiling
@ 2018-10-07 13:58 Sebastian Reuße
  2018-10-10 10:49 ` Nicolas Goaziou
  0 siblings, 1 reply; 13+ messages in thread
From: Sebastian Reuße @ 2018-10-07 13:58 UTC (permalink / raw)
  To: emacs-orgmode; +Cc: Sebastian Reuße

* org.el (org--refile-new-path): Add.
(org-refile): Use it.
(org-refile-new-child): Make new nodes more compact.

* test-org.el (test-org/org-refile): Add test.

While ‘org-refile’ currently supports creating new headlines when
refiling, only one single headline can be created this way. For
convenience, we now generalize this use-case to support creating
arbitrary headline paths on the fly.
---
 lisp/org.el              | 35 ++++++++++++++++++++-------------
 testing/lisp/test-org.el | 42 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 64 insertions(+), 13 deletions(-)

diff --git a/lisp/org.el b/lisp/org.el
index 8aa16bfd5..2af144418 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -11468,17 +11468,12 @@ (defun org-refile-get-location (&optional prompt default-buffer new-nodes)
 	    (when (equal (car org-refile-history) (nth 1 org-refile-history))
 	      (pop org-refile-history)))
 	  pa)
-      (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ)
-	  (progn
-	    (setq parent (match-string 1 answ)
-		  child (match-string 2 answ))
-	    (setq parent-target (org-refile--get-location parent tbl))
-	    (when (and parent-target
-		       (or (eq new-nodes t)
-			   (and (eq new-nodes 'confirm)
-				(y-or-n-p (format "Create new node \"%s\"? "
-						  child)))))
-	      (org-refile-new-child parent-target child)))
+      (if (and (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ)
+	       (or (eq new-nodes t)
+		   (and (eq new-nodes 'confirm)
+			(y-or-n-p (format "Create new path \"%s\"? "
+					  answ)))))
+	  (org--refile-new-path answ tbl)
 	(user-error "Invalid target location")))))
 
 (declare-function org-string-nw-p "org-macs" (s))
@@ -11502,6 +11497,20 @@ (defun org-refile-check-position (refile-pointer)
 	   (unless (looking-at-p re)
 	     (user-error "Invalid refile position, please clear the cache with `C-0 C-c C-w' before refiling"))))))))
 
+(defun org--refile-new-path (path tbl)
+  "Ensure that all parent nodes leading to refile target PATH exist.
+
+Use TBL as a look-up table for existing nodes.
+
+Return the corresponding refile location."
+  (let ((target (org-refile--get-location path tbl)))
+    (if (and (not target)
+	     (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" path))
+	(let ((child (match-string 2 path))
+	      (parent (org--refile-new-path (match-string 1 path) tbl)))
+	  (org-refile-new-child parent child))
+      target)))
+
 (defun org-refile-new-child (parent-target child)
   "Use refile target PARENT-TARGET to add new CHILD below it."
   (unless parent-target
@@ -11520,8 +11529,8 @@ (defun org-refile-new-child (parent-target child)
 	 (setq level (funcall outline-level))
 	 (org-end-of-subtree t t))
        (org-back-over-empty-lines)
-       (insert "\n" (make-string
-		     (if pos (org-get-valid-level level 1) 1) ?*)
+       (insert (make-string
+		(if pos (org-get-valid-level level 1) 1) ?*)
 	       " " child "\n")
        (beginning-of-line 0)
        (list (concat (car parent-target) "/" child) file "" (point))))))
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index 20164beb5..4036db92b 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -5789,6 +5789,48 @@
 	    (org-refile-targets `((nil :level . 1))))
        (member (buffer-name) (mapcar #'car (org-refile-get-targets)))))))
 
+(ert-deftest test-org/org-refile ()
+  "Test `org-refile' specifications."
+  ;; Create new parent nodes via `org--refile-new-path'.
+  (let* ((low-calorie-buffer "* Cake
+** Topping
+*** Rainbow chocolates
+*** Pistachio icing
+** Filling
+*** Banana ice cream
+*** Cookie dough
+*** Crispy crunch
+* Extra Ingredients
+** Marshmallows
+")
+	 (low-calorie-buffer-target "* Cake
+** Topping
+*** Rainbow chocolates
+*** Pistachio icing
+** Filling
+*** Banana ice cream
+*** Cookie dough
+*** Crispy crunch
+** Bottom
+*** Base
+**** Marshmallows
+* Extra Ingredients
+")
+	 (cursor-after "Marshmallows")
+	 (refile-target "Cake/Bottom/Base")
+	 (org-refile-use-outline-path t)
+	 (org-refile-targets nil)
+	 (org-refile-allow-creating-parent-nodes t))
+    (should
+     (equal
+      (org-test-with-temp-text-in-file low-calorie-buffer
+	(re-search-forward cursor-after)
+	(cl-letf (((symbol-function 'completing-read)
+		   (lambda (&rest args) refile-target)))
+	  (call-interactively #'org-refile))
+	(buffer-string))
+      low-calorie-buffer-target))))
+
 
 \f
 ;;; Sparse trees
-- 
2.19.0

^ permalink raw reply related	[flat|nested] 13+ messages in thread
end of thread, other threads:[~2018-10-14 20:24 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2018-10-07 13:58 [PATCH] org: Support creating arbitrary headline paths when refiling Sebastian Reuße
2018-10-10 10:49 ` Nicolas Goaziou
2018-10-10 11:24   ` Sebastian Reuße
2018-10-11  6:35     ` Sebastian Reuße
2018-10-11 11:30       ` Sebastian Reuße
2018-10-14  7:38         ` Nicolas Goaziou
2018-10-14  8:04           ` Sebastian Reuße
2018-10-14  8:58             ` Headlines with slashes " Sebastian Reuße
2018-10-14  8:05           ` [PATCH] org: Support creating arbitrary headline paths " Sebastian Reuße
2018-10-14 14:14             ` Nicolas Goaziou
2018-10-14 14:30               ` Sebastian Reuße
2018-10-14 20:24                 ` Nicolas Goaziou
2018-10-10 11:27   ` Sebastian Reuße

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).