Add command org-clone-and-shift-by-repeater

1 files changed, 39 insertions, 0 deletions

diff --git a/lisp/init-org.el b/lisp/init-org.el
index 9d00495..3c96d71 100644
--- a/lisp/init-org.el
+++ b/lisp/init-org.el
@@ -185,6 +185,45 @@ Before running `org-tree-to-indirect-buffer',
   (let ((org-indirect-buffer-display 'current-window))
     (org-tree-to-indirect-buffer arg)))
 
+(defun km/org-clone-and-shift-by-repeater ()
+  "Clone current subtree, shifting new timestamp by repeater.
+The repeater is removed from the original subtree."
+  (interactive)
+  (save-excursion
+    (org-back-to-heading)
+    (let* ((heading (org-element-at-point))
+           (tree-begin (org-element-property :begin heading))
+           (tree-end (org-element-property :end heading))
+           (tree (buffer-substring tree-begin tree-end))
+           (deadline (org-element-property :deadline heading))
+           (deadline-end (org-element-property :end deadline))
+           (repeat-val (org-element-property :repeater-value deadline))
+           (repeat-unit (org-element-property :repeater-unit deadline))
+           new-tree)
+      (cond
+       ((not deadline) (user-error "Heading doesn't have deadline"))
+       ((not repeat-val) (user-error "Deadline isn't repeating"))
+       ((eq repeat-unit 'week)
+        ;; `org-timestamp-change' doesn't recognize weeks.
+        (setq repeat-val (* repeat-val 7)
+              repeat-unit 'day)))
+      ;; Make new tree with repeater shifted one cycle.
+      (with-temp-buffer
+        (insert tree)
+        (goto-char (point-min))
+        (re-search-forward org-ts-regexp)
+        (org-timestamp-change repeat-val repeat-unit)
+        (setq new-tree (buffer-string)))
+      ;; Insert new tree with shifted repeater.
+      (goto-char tree-end)
+      (insert new-tree)
+      ;; Remove the repeater from the original tree.
+      (goto-char tree-begin)
+      (re-search-forward
+       ;; Regexp taken from `org-clone-subtree-with-time-shift'.
+       "<[^<>\n]+\\( +[.+]?\\+[0-9]+[hdwmy]\\)" deadline-end)
+      (delete-region (match-beginning 1) (match-end 1)))))
+
 (defun km/org-sort-parent (arg)
   "Sort on parent heading ARG levels up.
 After sorting, the point is returned to its previous location