[O] [PATCH] org: Support creating arbitrary headline paths when refiling

[Sebastian Reuße]

* org.el (org--refile-new-path): Add.
(org-refile): Use it.
(org-refile-new-child): Support creating new root nodes.

* 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              | 75 ++++++++++++++++++++++++----------------
 testing/lisp/test-org.el | 66 +++++++++++++++++++++++++++++++++++
 2 files changed, 112 insertions(+), 29 deletions(-)

diff --git a/lisp/org.el b/lisp/org.el
index e3866c2c0..dd82b005a 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -11450,7 +11450,7 @@ (defun org-refile-get-location (&optional prompt 
default-buffer new-nodes)
                                  (concat " (default " (car org-refile-history) 
")"))
                             (and (assoc cbnex tbl) (setq cdef cbnex)
                                  (concat " (default " cbnex ")"))) ": "))
-        pa answ parent-target child parent old-hist)
+        pa answ old-hist)
     (setq old-hist org-refile-history)
     (setq answ (funcall cfunc prompt tbl nil (not new-nodes)
                        nil 'org-refile-history (or cdef (car 
org-refile-history))))
@@ -11467,17 +11467,11 @@ (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 (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))
@@ -11501,29 +11495,52 @@ (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)))
+    (or target
+       (let (parent child)
+         (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" path)
+             (progn
+               (setq child (match-string 2 path))
+               (setq parent (org--refile-new-path (match-string 1 path) tbl)))
+           (setq child path))
+         (org-refile-new-child parent child)))))
+
+
 (defun org-refile-new-child (parent-target child)
-  "Use refile target PARENT-TARGET to add new CHILD below it."
-  (unless parent-target
-    (error "Cannot find parent for new node"))
-  (let ((file (nth 1 parent-target))
-       (pos (nth 3 parent-target))
-       level)
+  "Use refile target PARENT-TARGET to add new CHILD below it.
+
+When PARENT-TARGET is ‘nil’, child will be added below the
+outline root of the current file."
+  (let (file pos)
+    (if parent-target
+       (progn
+         (setq file (nth 1 parent-target))
+         (setq pos (nth 3 parent-target)))
+      (setq file (buffer-file-name)))
     (with-current-buffer (or (find-buffer-visiting file)
                             (find-file-noselect file))
       (org-with-wide-buffer
        (if pos
-          (goto-char pos)
+          (progn
+            (goto-char pos)
+            (org-insert-heading-respect-content)
+            (org-do-demote))
+        ;; New node is top-level
         (goto-char (point-max))
-        (unless (bolp) (newline)))
-       (when (looking-at org-outline-regexp)
-        (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) ?*)
-              " " child "\n")
-       (beginning-of-line 0)
-       (list (concat (car parent-target) "/" child) file "" (point))))))
+        (unless (bolp) (newline))
+        (org-insert-heading nil t t))
+       (insert child)
+       (beginning-of-line)
+       (list (if parent-target
+                (format "%s/%s" (car parent-target) child)
+              child)
+            file "" (point))))))
 
 (defun org-olpath-completing-read (prompt collection &rest args)
   "Read an outline path like a file name."
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index 3f5aa09e4..cc06e2936 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -5789,6 +5789,72 @@
            (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)))
+  ;; Create new root nodes via `org--refile-new-path'.
+  (let* ((have-buffer "* Onions
+* Pepper
+* Ham
+")
+        (want-buffer "* Pepper
+* Ham
+* Bread
+** Onions
+")
+        (cursor-after "Onions")
+        (refile-target "Bread")
+        (org-refile-use-outline-path nil)
+        (org-refile-targets nil)
+        (org-refile-allow-creating-parent-nodes t))
+    (should
+     (equal
+      (org-test-with-temp-text-in-file have-buffer
+       (re-search-forward cursor-after)
+       (cl-letf (((symbol-function 'completing-read)
+                  (lambda (&rest args) refile-target)))
+         (call-interactively #'org-refile))
+       (buffer-string))
+      want-buffer))))
+
 
 
 ;;; Sparse trees
-- 
2.19.1