diff --git a/lisp/ob-core.el b/lisp/ob-core.el index cc257a3b3..4dcfbd3b0 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -73,10 +73,12 @@ (declare-function org-element-parent "org-element-ast" (node)) (declare-function org-element-type "org-element-ast" (node &optional anonymous)) (declare-function org-element-type-p "org-element-ast" (node &optional types)) +(declare-function org-element-interpret-data "org-element" (data)) (declare-function org-entry-get "org" (pom property &optional inherit literal-nil)) (declare-function org-escape-code-in-region "org-src" (beg end)) (declare-function org-forward-heading-same-level "org" (arg &optional invisible-ok)) (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) +(declare-function org-indent-block "org" ()) (declare-function org-indent-line "org" ()) (declare-function org-list-get-list-end "org-list" (item struct prevs)) (declare-function org-list-prevs-alist "org-list" (struct)) @@ -700,8 +702,9 @@ By default, consider the block at point. However, when optional argument DATUM is provided, extract information from that parsed object instead. -Return nil if point is not on a source block. Otherwise, return -a list with the following pattern: +Return nil if point is not on a source block (blank lines after a +source block are considered a part of that source block). +Otherwise, return a list with the following pattern: (language body arguments switches name start coderef)" (let* ((datum (or datum (org-element-context))) @@ -2080,7 +2083,7 @@ With optional prefix argument ARG, jump backward ARG many source blocks." (goto-char (match-beginning 5))))) (defun org-babel-demarcate-block (&optional arg) - "Wrap or split the code in the region or on the point. + "Wrap or split the code in an active region or at point. With prefix argument ARG, also create a new heading at point. @@ -2090,41 +2093,76 @@ is created. In both cases if the region is demarcated and if the region is not active then the point is demarcated. When called within blank lines after a code block, create a new code -block of the same language with the previous." +block of the same language as the previous." (interactive "P") (let* ((info (org-babel-get-src-block-info 'no-eval)) (start (org-babel-where-is-src-block-head)) ;; `start' will be nil when within space lines after src block. (block (and start (match-string 0))) - (headers (and start (match-string 4))) + (body-beg (and start (match-beginning 5))) + (body-end (and start (match-end 5))) (stars (concat (make-string (or (org-current-level) 1) ?*) " ")) (upper-case-p (and block (let (case-fold-search) (string-match-p "#\\+BEGIN_SRC" block))))) (if (and info start) ;; At src block, but not within blank lines after it. - (mapc - (lambda (place) - (save-excursion - (goto-char place) - (let ((lang (nth 0 info)) - (indent (make-string (org-current-text-indentation) ?\s))) - (when (string-match "^[[:space:]]*$" - (buffer-substring (line-beginning-position) - (line-end-position))) - (delete-region (line-beginning-position) (line-end-position))) - (insert (concat - (if (looking-at "^") "" "\n") - indent (if upper-case-p "#+END_SRC\n" "#+end_src\n") - (if arg stars indent) "\n" - indent (if upper-case-p "#+BEGIN_SRC " "#+begin_src ") - lang - (if (> (length headers) 1) - (concat " " headers) headers) - (if (looking-at "[\n\r]") - "" - (concat "\n" (make-string (current-column) ? ))))))) - (move-end-of-line 2)) - (sort (if (org-region-active-p) (list (mark) (point)) (list (point))) #'>)) + (let* ((copy (org-element-copy (org-element-at-point))) + (before (org-element-begin copy)) + (beyond (org-element-end copy)) + (parts + (if (org-region-active-p) + (list body-beg (region-beginning) (region-end) body-end) + (list body-beg (point) body-end))) + (pads ;; To calculate left-side white-space padding. + (if (org-region-active-p) + (list (region-beginning) (region-end)) + (list (point)))) + (n (- (length parts) 2)) ;; 1 or 2 parts in `dolist' below. + ;; `post-blank' caches the property before setting it to 0. + (post-blank (org-element-property :post-blank copy))) + ;; Point or region are within body when parts is in increasing order. + (unless (apply #'<= parts) + (user-error "Select within the source block body to split it")) + (setq parts (mapcar (lambda (p) (buffer-substring (car p) (cdr p))) + (seq-mapn #'cons parts (cdr parts)))) + ;; Map positions to columns for white-space padding. + (setq pads (mapcar (lambda (p) (save-excursion + (goto-char p) + (current-column))) + pads)) + (push 0 pads) ;; The 1st part never requires white-space padding. + (setq parts (mapcar (lambda (p) (string-join + (list (make-string (car p) ?\s) + (cdr p)))) + (seq-mapn #'cons pads parts))) + (delete-region before beyond) + ;; Set `:post-blank' to 0. We take care of spacing between blocks. + (org-element-put-property copy :post-blank 0) + (org-element-put-property copy :value (car parts)) + (insert (org-element-interpret-data copy)) + ;; `org-indent-block' may see another `org-element' (e.g. paragraph) + ;; immediately after the block. Ensure to indent the inserted block + ;; and move point to its end. + (org-babel-previous-src-block 1) + (org-indent-block) + (goto-char (org-element-end (org-element-at-point))) + (org-element-put-property copy :caption nil) + (org-element-put-property copy :name nil) + ;; Insert the 2nd block, and the 3rd block when region is active. + (dolist (part (cdr parts)) + (org-element-put-property copy :value part) + (insert (if arg (concat stars "\n") "\n")) + (cl-decf n) + (when (= n 0) + ;; Use `post-blank' to reset the property of the last block. + (org-element-put-property copy :post-blank post-blank)) + (insert (org-element-interpret-data copy)) + ;; Ensure to indent the inserted block and move point to its end. + (org-babel-previous-src-block 1) + (org-indent-block) + (goto-char (org-element-end (org-element-at-point)))) + ;; Leave point at the last inserted block. + (goto-char (org-babel-previous-src-block 1))) (let ((start (point)) (lang (or (car info) ; Reuse language from previous block. (completing-read diff --git a/testing/lisp/test-ob.el b/testing/lisp/test-ob.el index 42c77ca56..c088af7c8 100644 --- a/testing/lisp/test-ob.el +++ b/testing/lisp/test-ob.el @@ -2545,6 +2545,225 @@ abc (lambda (&rest _) (error "No warnings should occur")))) (org-babel-import-elisp-from-file (buffer-file-name)))))) +(ert-deftest test-ob/demarcate-block-split-duplication () + "Test duplication of language, body, switches, and headers in splitting." + (let ((caption "#+caption: caption.") + (regexp (rx "#+caption: caption.")) + (org-adapt-indentation nil)) + (org-test-with-temp-text (format " +%s +#+header: :var edge=\"also duplicated\" +#+header: :wrap \"src any-spanish -n\" +#+name: Nobody +#+begin_src any-english -i -n :var here=\"duplicated\" :wrap \"src any-english -n\" + +above split + +below split + +#+end_src +do not org-indent-block text here +" caption) + (let ((wrap-val "src any-spanish -n") above below avars bvars) + (org-babel-demarcate-block) + (goto-char (point-min)) + (org-babel-next-src-block) ;; upper source block + (setq above (org-babel-get-src-block-info)) + (setq avars (org-babel--get-vars (nth 2 above))) + (org-babel-next-src-block) ;; lower source block + (setq below (org-babel-get-src-block-info)) + (setq bvars (org-babel--get-vars (nth 2 below))) + ;; duplicated multi-line header arguments: + (should (string= "also duplicated" (cdr (assq 'edge avars)))) + (should (string= "also duplicated" (cdr (assq 'edge bvars)))) + (should (string= wrap-val (cdr (assq :wrap (nth 2 above))))) + (should (string= wrap-val (cdr (assq :wrap (nth 2 below))))) + ;; duplicated language, other header arguments, and switches: + (should (string= "any-english" (nth 0 above))) + (should (string= "any-english" (nth 0 below))) + (should (string= "above split" (org-trim (nth 1 above)))) + (should (string= "below split" (org-trim (nth 1 below)))) + (should (string= "duplicated" (cdr (assq 'here avars)))) + (should (string= "duplicated" (cdr (assq 'here bvars)))) + (should (string= "-i -n" (nth 3 above))) + (should (string= "-i -n" (nth 3 below))) + ;; non-duplication of name and caption, which is not in above/below. + (should (string= "Nobody" (nth 4 above))) + (should-not (string= "" (nth 4 below))) + (goto-char (point-min)) + (should (re-search-forward regexp)) + (should-not (re-search-forward regexp nil 'noerror)))))) + +(ert-deftest test-ob/demarcate-block-split-prefix-point () + "Test prefix argument point splitting." + (let ((org-adapt-indentation t) + (org-edit-src-content-indentation 2) + (org-src-preserve-indentation nil) + (ok-col 11) + (stars "^\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*")) + (org-test-with-temp-text " +********** 10 stars with point between two lines + #+begin_src emacs-lisp + ;; to upper block + + ;; to lower block + #+end_src +" + (org-babel-demarcate-block 'a-prefix-arg) + (goto-char (point-min)) + (dolist (regexp `(,stars + "#\\+beg" ";; to upper block" "#\\+end" + ,stars + "#\\+beg" ";; to lower block" "#\\+end")) + (should (re-search-forward regexp)) + (goto-char (match-beginning 0)) + (cond ((string= regexp stars) + (should (= 0 (current-column)))) + ((string-prefix-p ";;" regexp) + (should (= (+ ok-col org-edit-src-content-indentation) + (current-column)))) + (t (should (= ok-col (current-column))))))))) + +(ert-deftest test-ob/demarcate-block-split-prefix-region () + "Test prefix argument region splitting." + (let ((org-adapt-indentation t) + (org-edit-src-content-indentation 2) + (org-src-preserve-indentation nil) + (ok-col 11) + (stars "^\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*") + (parts '("to upper block" "mark those words as region" "to lower block"))) + (org-test-with-temp-text (format " +********** 10 stars with region between two lines + #+header: :var b=\"also seen\" + #+begin_src any-language -i -n :var a=\"seen\" + %s + %s + %s + #+end_src +" (nth 0 parts) (nth 1 parts) (nth 2 parts)) + (let ((n 0) info vars) + (transient-mark-mode 1) + (push-mark (point) t t) + (search-forward (nth 1 parts)) + (org-babel-demarcate-block 'a-prefix-argument) + (goto-char (point-min)) + (while (< n (length parts)) + (org-babel-next-src-block) + (setq info (org-babel-get-src-block-info)) + (setq vars (org-babel--get-vars (nth 2 info))) + (should (string= "any-language" (nth 0 info))) + (should (string= (nth n parts) (org-trim (nth 1 info)))) + (should (string= "seen" (cdr (assq 'a vars)))) + (should (string= "also seen" (cdr (assq 'b vars)))) + (should (string= "-i -n" (nth 3 info))) + (cl-incf n))) + (goto-char (point-min)) + (dolist (regexp `(,stars + "#\\+beg" ,(nth 0 parts) "#\\+end" + ,stars + "#\\+beg" ,(nth 1 parts) "#\\+end" + ,stars + "#\\+beg" ,(nth 2 parts) "#\\+end")) + (should (re-search-forward regexp)) + (goto-char (match-beginning 0)) + (cond ((string= regexp stars) + (should (= 0 (current-column)))) + ((memq regexp parts) + (should (= (+ ok-col org-edit-src-content-indentation) + (current-column)))) + (t (should (= ok-col (current-column))))))))) + +(ert-deftest test-ob/demarcate-block-split-user-errors () + "Test for `user-error's in splitting" + (let ((org-adapt-indentation t) + (org-edit-src-content-indentation 2) + (org-src-preserve-indentation)) + (let* ((caption "#+caption: caption.") + (within-body ";; within-body") + (below-block "# below block") + (template " +%s%s +#+begin_src emacs-lisp + + %s + +#+end_src + +%s%s +")) + ;; Test point at caption. + (org-test-with-temp-text + (format template "" caption within-body below-block "") + (should-error (org-babel-demarcate-block) :type 'user-error)) + ;; Test region from below the block (mark) to within the body (point). + (org-test-with-temp-text + (format template "" caption within-body below-block "") + ;; Set mark. + (transient-mark-mode 1) + (push-mark (point) t t) + ;; Set point. + (should (search-backward within-body nil 'noerror)) + (goto-char (match-beginning 0)) + (should-error (org-babel-demarcate-block) :type 'user-error))))) + +(ert-deftest test-ob/demarcate-block-wrap-point () + "Test wrapping point in blank lines below a source block." + (org-test-with-temp-text " +#+begin_src any-language -i -n :var here=\"not duplicated\" +to upper block +#+end_src + +" + (let (info vars) + (org-babel-demarcate-block) + (goto-char (point-min)) + (org-babel-next-src-block) + (setq info (org-babel-get-src-block-info)) ;; upper source block info + (setq vars (org-babel--get-vars (nth 2 info))) + (should (string= "any-language" (nth 0 info))) + (should (string= "to upper block" (org-trim (nth 1 info)))) + (should (string= "not duplicated" (cdr (assq 'here vars)))) + (should (string= "-i -n" (nth 3 info))) + (org-babel-next-src-block) + (setq info (org-babel-get-src-block-info)) ;; lower source block info + (setq vars (org-babel--get-vars (nth 2 info))) + (should (string= "any-language" (nth 0 info))) + (should (string= "" (org-trim (nth 1 info)))) + (should-not vars) + (should (string= "" (nth 3 info)))))) + +(ert-deftest test-ob/demarcate-block-wrap-region () + "Test wrapping region in blank lines below a source block." + (let ((region-text "mark this line as region leaving point in blank lines")) + (org-test-with-temp-text (format " +#+begin_src any-language -i -n :var here=\"not duplicated\" +to upper block +#+end_src + +%s +" region-text) + (let (info vars) + (transient-mark-mode 1) + (push-mark (point) t t) + (search-forward region-text) + (exchange-point-and-mark) + (org-babel-demarcate-block) + (goto-char (point-min)) + (org-babel-next-src-block) + (setq info (org-babel-get-src-block-info)) ;; upper source block info + (setq vars (org-babel--get-vars (nth 2 info))) + (should (string= "any-language" (nth 0 info))) + (should (string= "to upper block" (org-trim (nth 1 info)))) + (should (string= "not duplicated" (cdr (assq 'here vars)))) + (should (string= "-i -n" (nth 3 info))) + (org-babel-next-src-block) + (setq info (org-babel-get-src-block-info)) ;; lower source block info + (setq vars (org-babel--get-vars (nth 2 info))) + (should (string= "any-language" (nth 0 info))) + (should (string= region-text (org-trim (nth 1 info)))) + (should-not vars) + (should (string= "" (nth 3 info))))))) + (provide 'test-ob) ;;; test-ob ends here