New command to clean up an exiting date tree.

If the dates of some entries have changed, the new command will move
them to the correct date in the tree.

lisp/ChangeLog

@@ -1,3 +1,10 @@
+2009-11-10  Carsten Dominik  <carsten.dominik@gmail.com>
+
+	* org-datetree.el (org-datetree-find-date-create): Respect
+	restriction when KEEP-RESTRICTION is set.
+	(org-datetree-file-entry-under): New function.
+	(org-datetree-cleanup): New command.
+
 2009-11-09  Carsten Dominik  <carsten.dominik@gmail.com>
 
 	* org-clock.el (org-clock-out, org-clock-cancel): Revert to

lisp/org-datetree.el

@@ -39,24 +39,28 @@ This is normally one, but if the buffer has an entry with a DATE_TREE
 property, the date tree will become a subtree under that entry, so the
 base level will be properly adjusted.")
 
-(defun org-datetree-find-date-create (date)
-  "Find or create an entry for DATE."
+(defun org-datetree-find-date-create (date &optional keep-restriction)
+  "Find or create an entry for DATE.
+If KEEP-RESTRICTION is non-nil, do not widen the buffer.
+When it is nit, the buffer will be widened to make sure an existing date
+tree can be found."
   (let ((year (nth 2 date))
 	(month (car date))
 	(day (nth 1 date)))
     (org-set-local 'org-datetree-base-level 1)
-    (widen)
+    (or keep-restriction (widen))
     (goto-char (point-min))
-    (when (re-search-forward "^[ \t]*:DATE_TREE:[ \t]+\\S-" nil t)
-      (org-back-to-heading t)
-      (org-set-local 'org-datetree-base-level
-		     (org-get-valid-level (funcall outline-level) 1))
-      (org-narrow-to-subtree))
-    (goto-char (point-min))
-    (org-datetree-find-year-create year)
-    (org-datetree-find-month-create year month)
-    (org-datetree-find-day-create year month day)
-    (goto-char (prog1 (point) (widen)))))
+    (save-restriction
+      (when (re-search-forward "^[ \t]*:DATE_TREE:[ \t]+\\S-" nil t)
+	(org-back-to-heading t)
+	(org-set-local 'org-datetree-base-level
+		       (org-get-valid-level (funcall outline-level) 1))
+	(org-narrow-to-subtree))
+      (goto-char (point-min))
+      (org-datetree-find-year-create year)
+      (org-datetree-find-month-create year month)
+      (org-datetree-find-day-create year month day)
+      (goto-char (prog1 (point) (widen))))))
 
 (defun org-datetree-find-year-create (year)
   (let ((re "^\\*+[ \t]+\\([12][0-9][0-9][0-9]\\)[ \t\n]")
@@ -134,6 +138,60 @@ base level will be properly adjusted.")
 			 "%B" (encode-time 0 0 0 1 month year))))))
     (beginning-of-line 1)))
 
+(defun org-datetree-file-entry-under (txt date)
+  "Insert a node TXT into the date tree under DATE."
+  (org-datetree-find-date-create date)
+  (let ((level (org-get-valid-level (funcall outline-level) 1)))
+    (org-end-of-subtree t t)
+    (org-back-over-empty-lines)
+    (org-paste-subtree level txt)))
+
+(defun org-datetree-cleanup ()
+  "Make sure all entries in the current tree are under the correct date.
+It may be useful to restrict the buffer to the applicable portion
+before running this command, even though the command tries to be smart."
+  (interactive)
+  (goto-char (point-min))
+  (let ((dre (concat "\\<" org-deadline-string "\\>[ \t]*\\'"))
+	(sre (concat "\\<" org-scheduled-string "\\>[ \t]*\\'"))
+	dct ts tmp date year month date pos hdl-pos)
+  (while (re-search-forward org-ts-regexp nil t)
+    (catch 'next
+      (setq ts (match-string 0))
+      (setq tmp (buffer-substring
+		 (max (point-at-bol) (- (match-beginning 0)
+					org-ds-keyword-length))
+		 (match-beginning 0)))
+      (if (or (string-match "-\\'" tmp)
+	      (string-match dre tmp)
+	      (string-match sre tmp))
+	  (throw 'next nil))
+      (setq dct (decode-time (org-time-string-to-time (match-string 0)))
+	    date (list (nth 4 dct) (nth 3 dct) (nth 5 dct))
+	    year (nth 2 date)
+	    month (car date)
+	    day (nth 1 date)
+	    pos (point))
+      (org-back-to-heading t)
+      (setq hdl-pos (point))
+      (unless (org-up-heading-safe)
+	;; No parent, we are not in a date tree
+	(goto-char pos)
+	(throw 'next nil))
+      (unless (looking-at "\\*+[ \t]+[0-9]+-[0-1][0-9]-[0-3][0-9]")
+	;; Parent looks wrong, we are not in a date tree
+	(goto-char pos)
+	(throw 'next nil))
+      (when (looking-at (format "\\*+[ \t]+%d-%02d-%02d" year month day))
+	;; At correct date already, do nothing
+	  (progn (goto-char pos) (throw 'next nil)))
+      ;; OK, we need to refile this entry
+      (goto-char hdl-pos)
+      (org-cut-subtree)
+      (save-excursion
+	(save-restriction
+	  (org-datetree-file-entry-under (current-kill 0) date)))))))
+
 (provide 'org-datetree)
 
 ;; arch-tag: 1daea962-fd08-448b-9f98-6e8b511b3601