From mboxrd@z Thu Jan 1 00:00:00 1970 From: =?UTF-8?q?Sebastian=20Reu=C3=9Fe?= Subject: [PATCH] org: Support creating arbitrary headline paths when refiling Date: Sun, 14 Oct 2018 10:04:49 +0200 Message-ID: <20181014080449.28048-1-seb@wirrsal.net> References: <87tvlpdlke.fsf@nicolasgoaziou.fr> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:47555) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gBbOc-0001B1-Al for emacs-orgmode@gnu.org; Sun, 14 Oct 2018 04:05:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gBbOW-0003Ch-Kr for emacs-orgmode@gnu.org; Sun, 14 Oct 2018 04:05:06 -0400 Received: from wirrsal.net ([188.68.36.149]:41700 helo=mail.wirrsal.net) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1gBbOV-0003Bf-Sc for emacs-orgmode@gnu.org; Sun, 14 Oct 2018 04:05:00 -0400 In-Reply-To: <87tvlpdlke.fsf@nicolasgoaziou.fr> 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: emacs-orgmode@gnu.org Cc: =?UTF-8?q?Sebastian=20Reu=C3=9Fe?= , mail@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 =E2=80=98org-refile=E2=80=99 currently supports creating new headli= nes 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 promp= t 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"))))) =20 (declare-function org-string-nw-p "org-macs" (s)) @@ -11501,29 +11495,52 @@ (defun org-refile-check-position (refile-pointe= r) (unless (looking-at-p re) (user-error "Invalid refile position, please clear the cache with = `C-0 C-c C-w' before refiling")))))))) =20 +(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 =E2=80=98nil=E2=80=99, child will be added below t= he +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)))))) =20 (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))))))= ) =20 +(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)))) + =20 =0C ;;; Sparse trees --=20 2.19.1