Merge branch 'master' of code.orgmode.org:bzg/org-mode

etc/ORG-NEWS

@@ -193,7 +193,6 @@ you should expect to see something like:
 #+BEGIN_EXAMPLE
   ,#+STARTUP: shrink
 #+END_EXAMPLE
-
 ** New functions
 *** ~org-insert-structure-template~
 
@@ -228,6 +227,17 @@ Org Tempo may be used as a replacement.  See details above.
 
 ** Miscellaneous
 
+*** New face: ~org-upcoming-distant-deadline~
+
+It is meant to be used as the face for distant deadlines, see
+~org-agenda-deadline-faces~
+
+*** ~org-paste-subtree~ no longer breaks sections
+
+Unless point is at the beginning of a headline, ~org-paste-subtree~
+now pastes the tree before the next visible headline.  If you need to
+break the section, use ~org-yank~ instead.
+
 *** ~org-table-insert-column~ inserts a column to the right
 
 It used to insert it on the left.  With this change,

lisp/org-faces.el

@@ -511,13 +511,18 @@ which days belong to the weekend."
     (((class color) (min-colors 8)  (background light)) (:foreground "red"))
     (((class color) (min-colors 8)  (background dark)) (:foreground "red" :bold t))
     (t (:bold t)))
-  "Face for items scheduled previously, and not yet done."
+  "Face for items scheduled previously, and not yet done.
+See also `org-agenda-deadline-faces'."
   :group 'org-faces)
 
+(defface org-upcoming-distant-deadline '((t :inherit org-default))
+  "Face for items scheduled previously, not done, and have a distant deadline.
+See also `org-agenda-deadline-faces'.")
+
 (defcustom org-agenda-deadline-faces
   '((1.0 . org-warning)
     (0.5 . org-upcoming-deadline)
-    (0.0 . default))
+    (0.0 . org-upcoming-distant-deadline))
   "Faces for showing deadlines in the agenda.
 This is a list of cons cells.  The cdr of each cell is a face to be used,
 and it can also just be like \\='(:foreground \"yellow\").

lisp/org-tempo.el

@@ -126,8 +126,9 @@ Goes through `org-structure-template-alist' and
 Unlike to `tempo-complete-tag', do not give a signal if a partial
 completion or no match at all is found.  Return nil if expansion
 didn't succeed."
-  (cl-letf (((symbol-function 'ding) #'ignore))
-    (tempo-complete-tag t)))
+  ;; `tempo-complete-tag' returns its SILENT argument when there is no
+  ;; completion available at all.
+  (not (eq 'fail (tempo-complete-tag 'fail))))
 
 ;;; Additional keywords
 

lisp/org.el

@@ -8242,6 +8242,7 @@ useful if the caller implements cut-and-paste as copy-then-paste-then-cut."
 
 (defun org-paste-subtree (&optional level tree for-yank remove)
   "Paste the clipboard as a subtree, with modification of headline level.
+
 The entire subtree is promoted or demoted in order to match a new headline
 level.
 
@@ -8269,42 +8270,35 @@ When REMOVE is non-nil, remove the subtree from the clipboard."
   (interactive "P")
   (setq tree (or tree (and kill-ring (current-kill 0))))
   (unless (org-kill-is-subtree-p tree)
-    (user-error "%s"
-		(substitute-command-keys
-		 "The kill is not a (set of) tree(s) - please use \\[yank] to yank anyway")))
+    (user-error
+     (substitute-command-keys
+      "The kill is not a (set of) tree(s).  Use `\\[yank]' to yank anyway")))
   (org-with-limited-levels
    (let* ((visp (not (org-invisible-p)))
 	  (txt tree)
-	  (^re_ "\\(\\*+\\)[  \t]*")
 	  (old-level (if (string-match org-outline-regexp-bol txt)
 			 (- (match-end 0) (match-beginning 0) 1)
 		       -1))
-	  (force-level (cond (level (prefix-numeric-value level))
-			     ((and (looking-at "[ \t]*$")
-				   (string-match
-				    "^\\*+$" (buffer-substring
-					      (point-at-bol) (point))))
-			      (- (match-end 0) (match-beginning 0)))
-			     ((and (bolp)
-				   (looking-at org-outline-regexp))
-			      (- (match-end 0) (point) 1))))
-	  (previous-level (save-excursion
-			    (condition-case nil
-				(progn
-				  (outline-previous-visible-heading 1)
-				  (if (looking-at ^re_)
-				      (- (match-end 0) (match-beginning 0) 1)
-				    1))
-			      (error 1))))
-	  (next-level (save-excursion
-			(condition-case nil
-			    (progn
-			      (or (looking-at org-outline-regexp)
-				  (outline-next-visible-heading 1))
-			      (if (looking-at ^re_)
-				  (- (match-end 0) (match-beginning 0) 1)
-				1))
-			  (error 1))))
+	  (force-level
+	   (cond
+	    (level (prefix-numeric-value level))
+	    ;; When point is right after the stars in an otherwise
+	    ;; empty headline, use stars as the forced level.
+	    ((and (looking-at-p "[ \t]*$")
+		  (string-match-p "^\\*+ *"
+				  (buffer-substring (line-beginning-position)
+						    (point))))
+	     (org-outline-level))
+	    ((looking-at-p org-outline-regexp-bol) (org-outline-level))))
+	  (previous-level
+	   (save-excursion
+	     (org-previous-visible-heading 1)
+	     (if (org-at-heading-p) (org-outline-level) 1)))
+	  (next-level
+	   (save-excursion
+	     (if (org-at-heading-p) (org-outline-level)
+	       (org-next-visible-heading 1)
+	       (if (org-at-heading-p) (org-outline-level) 1))))
 	  (new-level (or force-level (max previous-level next-level)))
 	  (shift (if (or (= old-level -1)
 			 (= new-level -1)
@@ -8312,16 +8306,19 @@ When REMOVE is non-nil, remove the subtree from the clipboard."
 		     0
 		   (- new-level old-level)))
 	  (delta (if (> shift 0) -1 1))
-	  (func (if (> shift 0) 'org-demote 'org-promote))
+	  (func (if (> shift 0) #'org-demote #'org-promote))
 	  (org-odd-levels-only nil)
 	  beg end newend)
-     ;; Remove the forced level indicator
-     (when force-level
-       (delete-region (point-at-bol) (point)))
-     ;; Paste
-     (beginning-of-line (if (bolp) 1 2))
+     ;; Remove the forced level indicator.
+     (when (and force-level (not level))
+       (delete-region (line-beginning-position) (point)))
+     ;; Paste before the next visible heading or at end of buffer,
+     ;; unless point is at the beginning of a headline.
+     (unless (and (bolp) (org-at-heading-p))
+       (org-next-visible-heading 1)
+       (unless (bolp) (insert "\n")))
      (setq beg (point))
-     (and (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt))
+     (when (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt))
      (insert-before-markers txt)
      (unless (string-suffix-p "\n" txt) (insert "\n"))
      (setq newend (point))
@@ -8332,7 +8329,7 @@ When REMOVE is non-nil, remove the subtree from the clipboard."
      (setq beg (point))
      (when (and (org-invisible-p) visp)
        (save-excursion (outline-show-heading)))
-     ;; Shift if necessary
+     ;; Shift if necessary.
      (unless (= shift 0)
        (save-restriction
 	 (narrow-to-region beg end)
@@ -8341,16 +8338,16 @@ When REMOVE is non-nil, remove the subtree from the clipboard."
 	   (setq shift (+ delta shift)))
 	 (goto-char (point-min))
 	 (setq newend (point-max))))
-     (when (or (called-interactively-p 'interactive) for-yank)
+     (when (or for-yank (called-interactively-p 'interactive))
        (message "Clipboard pasted as level %d subtree" new-level))
      (when (and (not for-yank) ; in this case, org-yank will decide about folding
 		kill-ring
-		(eq org-subtree-clip (current-kill 0))
+		(equal org-subtree-clip (current-kill 0))
 		org-subtree-clip-folded)
        ;; The tree was folded before it was killed/copied
        (outline-hide-subtree))
-     (and for-yank (goto-char newend))
-     (and remove (setq kill-ring (cdr kill-ring))))))
+     (when for-yank (goto-char newend))
+     (when remove (pop kill-ring)))))
 
 (defun org-kill-is-subtree-p (&optional txt)
   "Check if the current kill is an outline subtree, or a set of trees.
@@ -10544,31 +10541,37 @@ to read."
       (goto-char (point-min))
       (select-window cwin))))
 
-;;; The mark ring for links jumps
+
+;;; The Mark Ring
 
 (defvar org-mark-ring nil
   "Mark ring for positions before jumps in Org mode.")
+
 (defvar org-mark-ring-last-goto nil
   "Last position in the mark ring used to go back.")
+
 ;; Fill and close the ring
-(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded
-(dotimes (_ org-mark-ring-length)
-  (push (make-marker) org-mark-ring))
+(setq org-mark-ring nil)
+(setq org-mark-ring-last-goto nil) ;in case file is reloaded
+
+(dotimes (_ org-mark-ring-length) (push (make-marker) org-mark-ring))
 (setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring)
 	org-mark-ring)
 
 (defun org-mark-ring-push (&optional pos buffer)
-  "Put the current position or POS into the mark ring and rotate it."
+  "Put the current position into the mark ring and rotate it.
+Also push position into the Emacs mark ring.  If optional
+argument POS and BUFFER are not nil, mark this location instead."
   (interactive)
-  (setq pos (or pos (point)))
-  (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring))
-  (move-marker (car org-mark-ring)
-	       (or pos (point))
-	       (or buffer (current-buffer)))
-  (message "%s"
-	   (substitute-command-keys
-	    "Position saved to mark ring, go back with \
-`\\[org-mark-ring-goto]'.")))
+  (let ((pos (or pos (point)))
+	(buffer (or buffer (current-buffer))))
+    (with-current-buffer buffer
+      (org-with-point-at pos (push-mark nil t)))
+    (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring))
+    (move-marker (car org-mark-ring) pos buffer))
+  (message
+   (substitute-command-keys
+    "Position saved to mark ring, go back with `\\[org-mark-ring-goto]'.")))
 
 (defun org-mark-ring-goto (&optional n)
   "Jump to the previous position in the mark ring.

testing/lisp/test-org.el

@@ -6929,6 +6929,59 @@ Contents
      (org-set-visibility-according-to-property)
      (not (invisible-p (point))))))
 
+
+;;; Yank and Kill
+
+(ert-deftest test-org/paste-subtree ()
+  "Test `org-paste-subtree' specifications."
+  ;; Return an error if text to yank is not a set of subtrees.
+  (should-error (org-paste-subtree nil "Text"))
+  ;; Adjust level according to current one.
+  (should
+   (equal "* H\n* Text\n"
+	  (org-test-with-temp-text "* H\n<point>"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  (should
+   (equal "* H1\n** H2\n** Text\n"
+	  (org-test-with-temp-text "* H1\n** H2\n<point>"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  ;; When not on a heading, move to next heading before yanking.
+  (should
+   (equal "* H1\nParagraph\n* Text\n* H2"
+	  (org-test-with-temp-text "* H1\n<point>Paragraph\n* H2"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  ;; If point is between two headings, use the deepest level.
+  (should
+   (equal "* H1\n\n* Text\n* H2"
+	  (org-test-with-temp-text "* H1\n<point>\n* H2"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  (should
+   (equal "** H1\n\n** Text\n* H2"
+	  (org-test-with-temp-text "** H1\n<point>\n* H2"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  (should
+   (equal "* H1\n\n** Text\n** H2"
+	  (org-test-with-temp-text "* H1\n<point>\n** H2"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  ;; When on an empty heading, after the stars, deduce the new level
+  ;; from the number of stars.
+  (should
+   (equal "*** Text\n"
+	  (org-test-with-temp-text "*** <point>"
+	    (org-paste-subtree nil "* Text")
+	    (buffer-string))))
+  ;; Optional argument LEVEL forces a level for the subtree.
+  (should
+   (equal "* H\n*** Text\n"
+	  (org-test-with-temp-text "* H<point>"
+	    (org-paste-subtree 3 "* Text")
+	    (buffer-string)))))
 
 (provide 'test-org)