From: "Sebastian Reuße" <seb@wirrsal.net>
To: emacs-orgmode@gnu.org
Cc: "Sebastian Reuße" <seb@wirrsal.net>, mail@nicolasgoaziou.fr
Subject: [PATCH] org: Support creating arbitrary headline paths when refiling
Date: Sun, 14 Oct 2018 10:04:49 +0200 [thread overview]
Message-ID: <20181014080449.28048-1-seb@wirrsal.net> (raw)
In-Reply-To: <87tvlpdlke.fsf@nicolasgoaziou.fr>
* 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 | 67 +++++++++++++++++++++++++++++++++++
2 files changed, 113 insertions(+), 29 deletions(-)
diff --git a/lisp/org.el b/lisp/org.el
index e3866c2c0..59fed6c05 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..d7d69bb3c 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -5789,6 +5789,73 @@
(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")
+ (org-refile-use-outline-path t)
+ (org-refile-targets nil)
+ (org-refile-allow-creating-parent-nodes t))
+ (dolist (refile-target '("Cake/Bottom/Base"
+ "Cake/Bottom/Base/"))
+ (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))))
+
\f
;;; Sparse trees
--
2.19.1
next prev parent reply other threads:[~2018-10-14 8:05 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
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 [this message]
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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.orgmode.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20181014080449.28048-1-seb@wirrsal.net \
--to=seb@wirrsal.net \
--cc=emacs-orgmode@gnu.org \
--cc=mail@nicolasgoaziou.fr \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).