diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0a87a4d5f..1706a5a80 100755 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2009-11-10 Carsten Dominik + + * 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 * org-clock.el (org-clock-out, org-clock-cancel): Revert to diff --git a/lisp/org-datetree.el b/lisp/org-datetree.el index 0ef725a74..b363446c8 100644 --- a/lisp/org-datetree.el +++ b/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