Re: New feature: loop over siblings for some commands

[Bastien <bzg@altern.org>]

[-- Attachment #1: Type: text/plain, Size: 1379 bytes --]

Hi David,

David Maus <dmaus@ictsoc.de> writes:

> I highly recommend to not use this macro but to build the intended
> functionality with separate building blocks: Factor out the flesh of
> the respective functions (e.g. org-schedule) and use org-map-entries
> to map. As far as I can see, the latter provides all we need:

I took this road.

The first patch manually reverts the commit you are commenting.

The second patch lets `org-map-entries' take a region as a scope.

The third patch implements the "loop" functionality by just using
`org-map-entries', not a macro.

I'm sure we could have an `org-loop' macro factoring out the duplicate
code in the new `org-schedule' and `org-deadline'.  If you have time to
look at this, that will greatly help.

> Another abstraction: Instead
> 'org-loop-over-siblings-with-active-region' something like:
> 'org-loop-over-headlines-with-active-region' that can be set to a
> symbol or a list of symbols indicating which headings to loop over
> (e.g. 'siblings, 'children, ...).

The variable is now called `org-loop-over-headlines-in-active-region'
and understand these kind of values:

- nil: don't loop
- t: loop over all headlines
- "MATCH": a tag/property/todo match to loop over matching headlines

If you can test these patches and send some feedback, that'd be nice!

Thanks again for the analysis and the suggested solution.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Manually-revert-366254217ac6faea20a5d43fae065bd02880.patch --]
[-- Type: text/x-patch, Size: 25912 bytes --]

From 130dc4e2b1e6a353197a6277818b94b11c0c38d0 Mon Sep 17 00:00:00 2001
From: Bastien Guerry <bzg@altern.org>
Date: Wed, 27 Jul 2011 16:32:41 +0200
Subject: [PATCH 1/3] Manually revert
 366254217ac6faea20a5d43fae065bd028806eab.

As David Maus pointed out, the implementation is not good.

* org.el (org-deadline, org-schedule): Don't loop.
(org-loop-over-siblings-within-active-region-p): Remove.
* org-archive.el (org-archive-subtree)
(org-archive-to-archive-sibling, org-toggle-archive-tag):
Don't loop.

* org-macs.el (org-loop-over-siblings-in-active-region):
Remove.
---
 lisp/org-archive.el |  426 +++++++++++++++++++++++++--------------------------
 lisp/org-macs.el    |   20 ---
 lisp/org.el         |  144 ++++++++----------
 3 files changed, 276 insertions(+), 314 deletions(-)

diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 30e6184..f6898ea 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -192,159 +192,158 @@ If the cursor is not at a headline when this command is called, try all level
 1 trees.  If the cursor is on a headline, only try the direct children of
 this heading."
   (interactive "P")
-  (org-loop-over-siblings-in-active-region
-   (if find-done
-       (org-archive-all-done)
-     ;; Save all relevant TODO keyword-relatex variables
-     
-     (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
-	   (tr-org-todo-keywords-1 org-todo-keywords-1)
-	   (tr-org-todo-kwd-alist org-todo-kwd-alist)
-	   (tr-org-done-keywords org-done-keywords)
-	   (tr-org-todo-regexp org-todo-regexp)
-	   (tr-org-todo-line-regexp org-todo-line-regexp)
-	   (tr-org-odd-levels-only org-odd-levels-only)
-	   (this-buffer (current-buffer))
-	   ;; start of variables that will be used for saving context
-	   ;; The compiler complains about them - keep them anyway!
-	   (file (abbreviate-file-name
-		  (or (buffer-file-name (buffer-base-buffer))
-		      (error "No file associated to buffer"))))
-	   (olpath (mapconcat 'identity (org-get-outline-path) "/"))
-	   (time (format-time-string
-		  (substring (cdr org-time-stamp-formats) 1 -1)
-		  (current-time)))
-	   category todo priority ltags itags atags
-	   ;; end of variables that will be used for saving context
-	   location afile heading buffer level newfile-p infile-p visiting)
-       
-       ;; Find the local archive location
-       (setq location (org-get-local-archive-location)
-	     afile (org-extract-archive-file location)
-	     heading (org-extract-archive-heading location)
-	     infile-p (equal file (abbreviate-file-name afile)))
-       (unless afile
-	 (error "Invalid `org-archive-location'"))
-       
-       (if (> (length afile) 0)
-	   (setq newfile-p (not (file-exists-p afile))
-		 visiting (find-buffer-visiting afile)
-		 buffer (or visiting (find-file-noselect afile)))
-	 (setq buffer (current-buffer)))
-       (unless buffer
-	 (error "Cannot access file \"%s\"" afile))
-       (if (and (> (length heading) 0)
-		(string-match "^\\*+" heading))
-	   (setq level (match-end 0))
-	 (setq heading nil level 0))
-       (save-excursion
-	 (org-back-to-heading t)
-	 ;; Get context information that will be lost by moving the tree
-	 (setq category (org-get-category nil 'force-refresh)
-	       todo (and (looking-at org-todo-line-regexp)
-			 (match-string 2))
-	       priority (org-get-priority
-			 (if (match-end 3) (match-string 3) ""))
-	       ltags (org-get-tags)
-	       itags (org-delete-all ltags (org-get-tags-at))
-	       atags (org-get-tags-at))
-	 (setq ltags (mapconcat 'identity ltags " ")
-	       itags (mapconcat 'identity itags " "))
-	 ;; We first only copy, in case something goes wrong
-	 ;; we need to protect `this-command', to avoid kill-region sets it,
-	 ;; which would lead to duplication of subtrees
-	 (let (this-command) (org-copy-subtree 1 nil t))
-	 (set-buffer buffer)
-	 ;; Enforce org-mode for the archive buffer
-	 (if (not (org-mode-p))
-	     ;; Force the mode for future visits.
-	     (let ((org-insert-mode-line-in-empty-file t)
-		   (org-inhibit-startup t))
-	       (call-interactively 'org-mode)))
-	 (when newfile-p
-	   (goto-char (point-max))
-	   (insert (format "\nArchived entries from file %s\n\n"
-			   (buffer-file-name this-buffer))))
-	 ;; Force the TODO keywords of the original buffer
-	 (let ((org-todo-line-regexp tr-org-todo-line-regexp)
-	       (org-todo-keywords-1 tr-org-todo-keywords-1)
-	       (org-todo-kwd-alist tr-org-todo-kwd-alist)
-	       (org-done-keywords tr-org-done-keywords)
-	       (org-todo-regexp tr-org-todo-regexp)
-	       (org-todo-line-regexp tr-org-todo-line-regexp)
-	       (org-odd-levels-only
-		(if (local-variable-p 'org-odd-levels-only (current-buffer))
-		    org-odd-levels-only
-		  tr-org-odd-levels-only)))
-	   (goto-char (point-min))
-	   (show-all)
-	   (if heading
-	       (progn
-		 (if (re-search-forward
-		      (concat "^" (regexp-quote heading)
-			      (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
-		      nil t)
-		     (goto-char (match-end 0))
-		   ;; Heading not found, just insert it at the end
-		   (goto-char (point-max))
-		   (or (bolp) (insert "\n"))
-		   (insert "\n" heading "\n")
-		   (end-of-line 0))
-		 ;; Make the subtree visible
-		 (show-subtree)
-		 (if org-archive-reversed-order
-		     (progn
-		       (org-back-to-heading t)
-		       (outline-next-heading))
-		   (org-end-of-subtree t))
-		 (skip-chars-backward " \t\r\n")
-		 (and (looking-at "[ \t\r\n]*")
-		      (replace-match "\n\n")))
-	     ;; No specific heading, just go to end of file.
-	     (goto-char (point-max)) (insert "\n"))
-	   ;; Paste
-	   (org-paste-subtree (org-get-valid-level level (and heading 1)))
-	   ;; Shall we append inherited tags?
-	   (and itags
-		(or (and (eq org-archive-subtree-add-inherited-tags 'infile) 
-			 infile-p)
-		    (eq org-archive-subtree-add-inherited-tags t))
-		(org-set-tags-to atags))
-	   ;; Mark the entry as done
-	   (when (and org-archive-mark-done
-		      (looking-at org-todo-line-regexp)
-		      (or (not (match-end 2))
-			  (not (member (match-string 2) org-done-keywords))))
-	     (let (org-log-done org-todo-log-states)
-	       (org-todo
-		(car (or (member org-archive-mark-done org-done-keywords)
-			 org-done-keywords)))))
-	   
-	   ;; Add the context info
-	   (when org-archive-save-context-info
-	     (let ((l org-archive-save-context-info) e n v)
-	       (while (setq e (pop l))
-		 (when (and (setq v (symbol-value e))
-			    (stringp v) (string-match "\\S-" v))
-		   (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
-		   (org-entry-put (point) n v)))))
-	   
-	   ;; Save and kill the buffer, if it is not the same buffer.
-	   (when (not (eq this-buffer buffer))
-	     (save-buffer))))
-       ;; Here we are back in the original buffer.  Everything seems to have
-       ;; worked.  So now cut the tree and finish up.
-       (let (this-command) (org-cut-subtree))
-       (when (featurep 'org-inlinetask)
-	 (org-inlinetask-remove-END-maybe))
-       (setq org-markers-to-move nil)
-       (message "Subtree archived %s"
-		(if (eq this-buffer buffer)
-		    (concat "under heading: " heading)
-		  (concat "in file: " (abbreviate-file-name afile))))))
-   (org-reveal)
-   (if (looking-at "^[ \t]*$")
-       (outline-next-visible-heading 1))))
+  (if find-done
+      (org-archive-all-done)
+    ;; Save all relevant TODO keyword-relatex variables
+    
+    (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
+	  (tr-org-todo-keywords-1 org-todo-keywords-1)
+	  (tr-org-todo-kwd-alist org-todo-kwd-alist)
+	  (tr-org-done-keywords org-done-keywords)
+	  (tr-org-todo-regexp org-todo-regexp)
+	  (tr-org-todo-line-regexp org-todo-line-regexp)
+	  (tr-org-odd-levels-only org-odd-levels-only)
+	  (this-buffer (current-buffer))
+	  ;; start of variables that will be used for saving context
+	  ;; The compiler complains about them - keep them anyway!
+	  (file (abbreviate-file-name
+		 (or (buffer-file-name (buffer-base-buffer))
+		     (error "No file associated to buffer"))))
+	  (olpath (mapconcat 'identity (org-get-outline-path) "/"))
+	  (time (format-time-string
+		 (substring (cdr org-time-stamp-formats) 1 -1)
+		 (current-time)))
+	  category todo priority ltags itags atags
+	  ;; end of variables that will be used for saving context
+	  location afile heading buffer level newfile-p infile-p visiting)
+      
+      ;; Find the local archive location
+      (setq location (org-get-local-archive-location)
+	    afile (org-extract-archive-file location)
+	    heading (org-extract-archive-heading location)
+	    infile-p (equal file (abbreviate-file-name afile)))
+      (unless afile
+	(error "Invalid `org-archive-location'"))
+      
+      (if (> (length afile) 0)
+	  (setq newfile-p (not (file-exists-p afile))
+		visiting (find-buffer-visiting afile)
+		buffer (or visiting (find-file-noselect afile)))
+	(setq buffer (current-buffer)))
+      (unless buffer
+	(error "Cannot access file \"%s\"" afile))
+      (if (and (> (length heading) 0)
+	       (string-match "^\\*+" heading))
+	  (setq level (match-end 0))
+	(setq heading nil level 0))
+      (save-excursion
+	(org-back-to-heading t)
+	;; Get context information that will be lost by moving the tree
+	(setq category (org-get-category nil 'force-refresh)
+	      todo (and (looking-at org-todo-line-regexp)
+			(match-string 2))
+	      priority (org-get-priority
+			(if (match-end 3) (match-string 3) ""))
+	      ltags (org-get-tags)
+	      itags (org-delete-all ltags (org-get-tags-at))
+	      atags (org-get-tags-at))
+	(setq ltags (mapconcat 'identity ltags " ")
+	      itags (mapconcat 'identity itags " "))
+	;; We first only copy, in case something goes wrong
+	;; we need to protect `this-command', to avoid kill-region sets it,
+	;; which would lead to duplication of subtrees
+	(let (this-command) (org-copy-subtree 1 nil t))
+	(set-buffer buffer)
+	;; Enforce org-mode for the archive buffer
+	(if (not (org-mode-p))
+	    ;; Force the mode for future visits.
+	    (let ((org-insert-mode-line-in-empty-file t)
+		  (org-inhibit-startup t))
+	      (call-interactively 'org-mode)))
+	(when newfile-p
+	  (goto-char (point-max))
+	  (insert (format "\nArchived entries from file %s\n\n"
+			  (buffer-file-name this-buffer))))
+	;; Force the TODO keywords of the original buffer
+	(let ((org-todo-line-regexp tr-org-todo-line-regexp)
+	      (org-todo-keywords-1 tr-org-todo-keywords-1)
+	      (org-todo-kwd-alist tr-org-todo-kwd-alist)
+	      (org-done-keywords tr-org-done-keywords)
+	      (org-todo-regexp tr-org-todo-regexp)
+	      (org-todo-line-regexp tr-org-todo-line-regexp)
+	      (org-odd-levels-only
+	       (if (local-variable-p 'org-odd-levels-only (current-buffer))
+		   org-odd-levels-only
+		 tr-org-odd-levels-only)))
+	  (goto-char (point-min))
+	  (show-all)
+	  (if heading
+	      (progn
+		(if (re-search-forward
+		     (concat "^" (regexp-quote heading)
+			     (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)"))
+		     nil t)
+		    (goto-char (match-end 0))
+		  ;; Heading not found, just insert it at the end
+		  (goto-char (point-max))
+		  (or (bolp) (insert "\n"))
+		  (insert "\n" heading "\n")
+		  (end-of-line 0))
+		;; Make the subtree visible
+		(show-subtree)
+		(if org-archive-reversed-order
+		    (progn
+		      (org-back-to-heading t)
+		      (outline-next-heading))
+		  (org-end-of-subtree t))
+		(skip-chars-backward " \t\r\n")
+		(and (looking-at "[ \t\r\n]*")
+		     (replace-match "\n\n")))
+	    ;; No specific heading, just go to end of file.
+	    (goto-char (point-max)) (insert "\n"))
+	  ;; Paste
+	  (org-paste-subtree (org-get-valid-level level (and heading 1)))
+	  ;; Shall we append inherited tags?
+	  (and itags
+	       (or (and (eq org-archive-subtree-add-inherited-tags 'infile) 
+			infile-p)
+		   (eq org-archive-subtree-add-inherited-tags t))
+	       (org-set-tags-to atags))
+	  ;; Mark the entry as done
+	  (when (and org-archive-mark-done
+		     (looking-at org-todo-line-regexp)
+		     (or (not (match-end 2))
+			 (not (member (match-string 2) org-done-keywords))))
+	    (let (org-log-done org-todo-log-states)
+	      (org-todo
+	       (car (or (member org-archive-mark-done org-done-keywords)
+			org-done-keywords)))))
+	  
+	  ;; Add the context info
+	  (when org-archive-save-context-info
+	    (let ((l org-archive-save-context-info) e n v)
+	      (while (setq e (pop l))
+		(when (and (setq v (symbol-value e))
+			   (stringp v) (string-match "\\S-" v))
+		  (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
+		  (org-entry-put (point) n v)))))
+	  
+	  ;; Save and kill the buffer, if it is not the same buffer.
+	  (when (not (eq this-buffer buffer))
+	    (save-buffer))))
+      ;; Here we are back in the original buffer.  Everything seems to have
+      ;; worked.  So now cut the tree and finish up.
+      (let (this-command) (org-cut-subtree))
+      (when (featurep 'org-inlinetask)
+	(org-inlinetask-remove-END-maybe))
+      (setq org-markers-to-move nil)
+      (message "Subtree archived %s"
+	       (if (eq this-buffer buffer)
+		   (concat "under heading: " heading)
+		 (concat "in file: " (abbreviate-file-name afile))))))
+  (org-reveal)
+  (if (looking-at "^[ \t]*$")
+      (outline-next-visible-heading 1)))
 
 (defun org-archive-to-archive-sibling ()
   "Archive the current heading by moving it under the archive sibling.
@@ -352,56 +351,55 @@ The archive sibling is a sibling of the heading with the heading name
 `org-archive-sibling-heading' and an `org-archive-tag' tag.  If this
 sibling does not exist, it will be created at the end of the subtree."
   (interactive)
-  (org-loop-over-siblings-in-active-region
-   (save-restriction
-     (widen)
-     (let (b e pos leader level)
-       (org-back-to-heading t)
-       (looking-at outline-regexp)
-       (setq leader (match-string 0)
-	     level (funcall outline-level))
-       (setq pos (point))
-       (condition-case nil
-	   (outline-up-heading 1 t)
-	 (error (setq e (point-max)) (goto-char (point-min))))
-       (setq b (point))
-       (unless e
-	 (condition-case nil
-	     (org-end-of-subtree t t)
-	   (error (goto-char (point-max))))
-	 (setq e (point)))
-       (goto-char b)
-       (unless (re-search-forward
-		(concat "^" (regexp-quote leader)
-			"[ \t]*"
-			org-archive-sibling-heading
-			"[ \t]*:"
-			org-archive-tag ":") e t)
-	 (goto-char e)
-	 (or (bolp) (newline))
-	 (insert leader org-archive-sibling-heading "\n")
-	 (beginning-of-line 0)
-	 (org-toggle-tag org-archive-tag 'on))
-       (beginning-of-line 1)
-       (if org-archive-reversed-order
-	   (outline-next-heading)
-	 (org-end-of-subtree t t))
-       (save-excursion
-	 (goto-char pos)
-	 (let ((this-command this-command)) (org-cut-subtree)))
-       (org-paste-subtree (org-get-valid-level level 1))
-       (org-set-property
-	"ARCHIVE_TIME"
-	(format-time-string
-	 (substring (cdr org-time-stamp-formats) 1 -1)
-	 (current-time)))
-       (outline-up-heading 1 t)
-       (hide-subtree)
-       (org-cycle-show-empty-lines 'folded)
-       (goto-char pos)))
-   (org-reveal)
-   (if (looking-at "^[ \t]*$")
-       (outline-next-visible-heading 1))))
+  (save-restriction
+    (widen)
+    (let (b e pos leader level)
+      (org-back-to-heading t)
+      (looking-at outline-regexp)
+      (setq leader (match-string 0)
+	    level (funcall outline-level))
+      (setq pos (point))
+      (condition-case nil
+	  (outline-up-heading 1 t)
+	(error (setq e (point-max)) (goto-char (point-min))))
+      (setq b (point))
+      (unless e
+	(condition-case nil
+	    (org-end-of-subtree t t)
+	  (error (goto-char (point-max))))
+	(setq e (point)))
+      (goto-char b)
+      (unless (re-search-forward
+	       (concat "^" (regexp-quote leader)
+		       "[ \t]*"
+		       org-archive-sibling-heading
+		       "[ \t]*:"
+		       org-archive-tag ":") e t)
+	(goto-char e)
+	(or (bolp) (newline))
+	(insert leader org-archive-sibling-heading "\n")
+	(beginning-of-line 0)
+	(org-toggle-tag org-archive-tag 'on))
+      (beginning-of-line 1)
+      (if org-archive-reversed-order
+	  (outline-next-heading)
+	(org-end-of-subtree t t))
+      (save-excursion
+	(goto-char pos)
+	(let ((this-command this-command)) (org-cut-subtree)))
+      (org-paste-subtree (org-get-valid-level level 1))
+      (org-set-property
+       "ARCHIVE_TIME"
+       (format-time-string
+	(substring (cdr org-time-stamp-formats) 1 -1)
+	(current-time)))
+      (outline-up-heading 1 t)
+      (hide-subtree)
+      (org-cycle-show-empty-lines 'folded)
+      (goto-char pos)))
+  (org-reveal)
+  (if (looking-at "^[ \t]*$")
+      (outline-next-visible-heading 1)))
 
 (defun org-archive-all-done (&optional tag)
   "Archive sublevels of the current tree without open TODO items.
@@ -452,22 +450,20 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
 With prefix ARG, check all children of current headline and offer tagging
 the children that do not contain any open TODO items."
   (interactive "P")
-  (org-loop-over-siblings-in-active-region
-   (if find-done
-       (org-archive-all-done 'tag)
-     (let (set)
-       (save-excursion
-	 (org-back-to-heading t)
-	 (setq set (org-toggle-tag org-archive-tag))
-	 (when set (hide-subtree)))
-       (and set (beginning-of-line 1))
-       (message "Subtree %s" (if set "archived" "unarchived"))))))
+  (if find-done
+      (org-archive-all-done 'tag)
+    (let (set)
+      (save-excursion
+	(org-back-to-heading t)
+	(setq set (org-toggle-tag org-archive-tag))
+	(when set (hide-subtree)))
+      (and set (beginning-of-line 1))
+      (message "Subtree %s" (if set "archived" "unarchived")))))
 
 (defun org-archive-set-tag ()
   "Set the ARCHIVE tag."
   (interactive)
-  (org-loop-over-siblings-in-active-region
-   (org-toggle-tag org-archive-tag 'on)))
+  (org-toggle-tag org-archive-tag 'on))
 
 ;;;###autoload
 (defun org-archive-subtree-default ()
diff --git a/lisp/org-macs.el b/lisp/org-macs.el
index 77a664e..7eac05b 100644
--- a/lisp/org-macs.el
+++ b/lisp/org-macs.el
@@ -370,26 +370,6 @@ The number of levels is controlled by `org-inlinetask-min-level'"
       (format-seconds string seconds)
     (format-time-string string (seconds-to-time seconds))))
 
-(defmacro org-loop-over-siblings-in-active-region (&rest body)
-  "Execute BODY on possibly several headlines."
-  `(if (or (not (org-region-active-p))
-	   (not org-loop-over-siblings-within-active-region-p))
-       ,@body
-     (save-excursion
-       (let ((beg (region-beginning))
-	     (end (region-end))
-	     mrkrs mrkr nxt)
-	 (goto-char beg)
-	 (or (org-at-heading-p) (outline-next-heading))
-	 (setq mrkrs (list (set-marker (make-marker) (point))))
-	 (while (and (setq nxt (org-get-next-sibling)) (< nxt end))
-	   (setq mrkrs 
-		 (append mrkrs (list (set-marker 
-				      (make-marker) (point))))))
-	 (while (setq mrkr (pop mrkrs))
-	   (goto-char mrkr)
-	   ,@body)))))
-
 (provide 'org-macs)
 
 ;; arch-tag: 7e6a73ce-aac9-4fc0-9b30-ce6f89dc6668
diff --git a/lisp/org.el b/lisp/org.el
index 5a4517a..8ef9c9a 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -1981,18 +1981,6 @@ heading."
   "The available interpretation symbols for customizing `org-todo-keywords'.
 Interested libraries should add to this list.")
 
-(defcustom org-loop-over-siblings-within-active-region-p nil
-  "Shall some commands act upon siblings in the active region?
-The list of commands is:
-- `org-schedule'
-- `org-deadline'
-- `org-archive-subtree'
-- `org-archive-to-archive-sibling'
-- `org-archive-set-tag'
-- `org-toggle-archive-tag'"
-  :group 'org-todo
-  :group 'org-archive)
-
 (defcustom org-todo-keywords '((sequence "TODO" "DONE"))
   "List of TODO entry keyword sequences and their interpretation.
 \\<org-mode-map>This is a list of sequences.
@@ -11711,40 +11699,39 @@ With argument REMOVE, remove any deadline from the item.
 With argument TIME, set the deadline at the corresponding date.  TIME
 can either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
   (interactive "P")
-  (org-loop-over-siblings-in-active-region
-   (let* ((old-date (org-entry-get nil "DEADLINE"))
-	  (repeater (and old-date
-			 (string-match
-			  "\\([.+-]+[0-9]+[dwmy]\\(?:[/ ][-+]?[0-9]+[dwmy]\\)?\\) ?"
+  (let* ((old-date (org-entry-get nil "DEADLINE"))
+	 (repeater (and old-date
+			(string-match
+			 "\\([.+-]+[0-9]+[dwmy]\\(?:[/ ][-+]?[0-9]+[dwmy]\\)?\\) ?"
 			  old-date)
-			 (match-string 1 old-date))))
-     (if remove
-	 (progn
-	   (when (and old-date org-log-redeadline)
-	     (org-add-log-setup 'deldeadline nil old-date 'findpos
-				org-log-redeadline))
-	   (org-remove-timestamp-with-keyword org-deadline-string)
-	   (message "Item no longer has a deadline."))
-       (org-add-planning-info 'deadline time 'closed)
-       (when (and old-date org-log-redeadline
-		  (not (equal old-date
-			      (substring org-last-inserted-timestamp 1 -1))))
-	 (org-add-log-setup 'redeadline nil old-date 'findpos
-			    org-log-redeadline))
-       (when repeater
-	 (save-excursion
-	   (org-back-to-heading t)
-	   (when (re-search-forward (concat org-deadline-string " "
-					    org-last-inserted-timestamp)
-				    (save-excursion
-				      (outline-next-heading) (point)) t)
-	     (goto-char (1- (match-end 0)))
-	     (insert " " repeater)
-	     (setq org-last-inserted-timestamp
-		   (concat (substring org-last-inserted-timestamp 0 -1)
-			   " " repeater
-			   (substring org-last-inserted-timestamp -1))))))
-       (message "Deadline on %s" org-last-inserted-timestamp)))))
+			(match-string 1 old-date))))
+    (if remove
+	(progn
+	  (when (and old-date org-log-redeadline)
+	    (org-add-log-setup 'deldeadline nil old-date 'findpos
+			       org-log-redeadline))
+	  (org-remove-timestamp-with-keyword org-deadline-string)
+	  (message "Item no longer has a deadline."))
+      (org-add-planning-info 'deadline time 'closed)
+      (when (and old-date org-log-redeadline
+		 (not (equal old-date
+			     (substring org-last-inserted-timestamp 1 -1))))
+	(org-add-log-setup 'redeadline nil old-date 'findpos
+			   org-log-redeadline))
+      (when repeater
+	(save-excursion
+	  (org-back-to-heading t)
+	  (when (re-search-forward (concat org-deadline-string " "
+					   org-last-inserted-timestamp)
+				   (save-excursion
+				     (outline-next-heading) (point)) t)
+	    (goto-char (1- (match-end 0)))
+	    (insert " " repeater)
+	    (setq org-last-inserted-timestamp
+		  (concat (substring org-last-inserted-timestamp 0 -1)
+			  " " repeater
+			  (substring org-last-inserted-timestamp -1))))))
+      (message "Deadline on %s" org-last-inserted-timestamp))))
 
 (defun org-schedule (&optional remove time)
   "Insert the SCHEDULED: string with a timestamp to schedule a TODO item.
@@ -11752,40 +11739,39 @@ With argument REMOVE, remove any scheduling date from the item.
 With argument TIME, scheduled at the corresponding date.  TIME can
 either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
   (interactive "P")
-  (org-loop-over-siblings-in-active-region
-   (let* ((old-date (org-entry-get nil "SCHEDULED"))
-	  (repeater (and old-date
-			 (string-match
-			  "\\([.+-]+[0-9]+[dwmy]\\(?:[/ ][-+]?[0-9]+[dwmy]\\)?\\) ?"
-			  old-date)
-			 (match-string 1 old-date))))
-     (if remove
-	 (progn
-	   (when (and old-date org-log-reschedule)
-	     (org-add-log-setup 'delschedule nil old-date 'findpos
-				org-log-reschedule))
-	   (org-remove-timestamp-with-keyword org-scheduled-string)
-	   (message "Item is no longer scheduled."))
-       (org-add-planning-info 'scheduled time 'closed)
-       (when (and old-date org-log-reschedule
-		  (not (equal old-date
-			      (substring org-last-inserted-timestamp 1 -1))))
-	 (org-add-log-setup 'reschedule nil old-date 'findpos
-			    org-log-reschedule))
-       (when repeater
-	 (save-excursion
-	   (org-back-to-heading t)
-	   (when (re-search-forward (concat org-scheduled-string " "
-					    org-last-inserted-timestamp)
-				    (save-excursion
-				      (outline-next-heading) (point)) t)
-	     (goto-char (1- (match-end 0)))
-	     (insert " " repeater)
-	     (setq org-last-inserted-timestamp
-		   (concat (substring org-last-inserted-timestamp 0 -1)
-			   " " repeater
-			   (substring org-last-inserted-timestamp -1))))))
-       (message "Scheduled to %s" org-last-inserted-timestamp)))))
+  (let* ((old-date (org-entry-get nil "SCHEDULED"))
+	 (repeater (and old-date
+			(string-match
+			 "\\([.+-]+[0-9]+[dwmy]\\(?:[/ ][-+]?[0-9]+[dwmy]\\)?\\) ?"
+			 old-date)
+			(match-string 1 old-date))))
+    (if remove
+	(progn
+	  (when (and old-date org-log-reschedule)
+	    (org-add-log-setup 'delschedule nil old-date 'findpos
+			       org-log-reschedule))
+	  (org-remove-timestamp-with-keyword org-scheduled-string)
+	  (message "Item is no longer scheduled."))
+      (org-add-planning-info 'scheduled time 'closed)
+      (when (and old-date org-log-reschedule
+		 (not (equal old-date
+			     (substring org-last-inserted-timestamp 1 -1))))
+	(org-add-log-setup 'reschedule nil old-date 'findpos
+			   org-log-reschedule))
+      (when repeater
+	(save-excursion
+	  (org-back-to-heading t)
+	  (when (re-search-forward (concat org-scheduled-string " "
+					   org-last-inserted-timestamp)
+				   (save-excursion
+				     (outline-next-heading) (point)) t)
+	    (goto-char (1- (match-end 0)))
+	    (insert " " repeater)
+	    (setq org-last-inserted-timestamp
+		  (concat (substring org-last-inserted-timestamp 0 -1)
+			  " " repeater
+			  (substring org-last-inserted-timestamp -1))))))
+      (message "Scheduled to %s" org-last-inserted-timestamp))))
 
 (defun org-get-scheduled-time (pom &optional inherit)
   "Get the scheduled time as a time tuple, of a format suitable
-- 
1.7.5.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-org.el-org-map-entries-Allow-SCOPE-to-be-the-active-.patch --]
[-- Type: text/x-patch, Size: 1361 bytes --]

From f9b98d4f98df81ea1702beef52ce1939dcdc8f5f Mon Sep 17 00:00:00 2001
From: Bastien Guerry <bzg@altern.org>
Date: Wed, 27 Jul 2011 16:34:31 +0200
Subject: [PATCH 2/3] org.el: (org-map-entries): Allow SCOPE to be the active
 region.

---
 lisp/org.el |   12 ++++++++----
 1 files changed, 8 insertions(+), 4 deletions(-)

diff --git a/lisp/org.el b/lisp/org.el
index 8ef9c9a..36b290a 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -13464,6 +13464,7 @@ SCOPE determines the scope of this command.  It can be any of:
 
 nil     The current buffer, respecting the restriction if any
 tree    The subtree started with the entry at point
+region  The entries within the active region, if any
 file    The current buffer, without restriction
 file-with-archives
         The current buffer, and any archives associated with it
@@ -13512,10 +13513,13 @@ a *different* entry, you cannot use these techniques."
 
     (save-excursion
       (save-restriction
-	(when (eq scope 'tree)
-	  (org-back-to-heading t)
-	  (org-narrow-to-subtree)
-	  (setq scope nil))
+	(cond ((eq scope 'tree)
+	       (org-back-to-heading t)
+	       (org-narrow-to-subtree)
+	       (setq scope nil))
+	      ((and (eq scope 'region) (org-region-active-p))
+	       (narrow-to-region (region-beginning) (region-end))
+	       (setq scope nil)))
 
 	(if (not scope)
 	    (progn
-- 
1.7.5.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0003-New-implementation-for-org-loop-over-headlines-in-ac.patch --]
[-- Type: text/x-patch, Size: 3831 bytes --]

From 6fb1d3ec1dafed6389447dc7acef5c237457d263 Mon Sep 17 00:00:00 2001
From: Bastien Guerry <bzg@altern.org>
Date: Wed, 27 Jul 2011 17:20:18 +0200
Subject: [PATCH 3/3] New implementation for
 `org-loop-over-headlines-in-active-region'.

`org-schedule' and `org-deadline' don't use a macro anymore.

* org.el (org-schedule-do): Rename from `org-schedule'.
(org-schedule): Add a loop.
(org-deadline-do): Rename from `org-deadline'.
(org-deadline): Add a loop.
(org-map-entries): Use org-end-of-subtree to make sure the
active region contains the whole subtree.
(org-loop-over-headlines-in-active-region): New variable.
---
 lisp/org.el |   46 +++++++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 45 insertions(+), 1 deletions(-)

diff --git a/lisp/org.el b/lisp/org.el
index 36b290a..aa1b206 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -396,6 +396,25 @@ is Emacs 23 only."
 	  (const :tag "When outside special context" t)
 	  (const :tag "Everywhere except timestamps" always)))
 
+(defcustom org-loop-over-headlines-in-active-region nil
+  "Shall some commands act upon headlines in the active region?
+
+When set to `t', some commands will be performed in all headlines
+within the active region.
+
+When set to a string, those commands will be performed on the
+matching headlines within the active region.  Such string must be
+a tags/property/todo match as it is used in the agenda tags view.
+
+The list of commands is:
+- `org-schedule'
+- `org-deadline'"
+  :type '(choice (const :tag "Don't loop" nil)
+		 (const :tag "All headlines in active region" t)
+		 (string :tag "Tags/Property/Todo matcher"))
+  :group 'org-todo
+  :group 'org-archive)
+
 (defgroup org-startup nil
   "Options concerning startup of Org-mode."
   :tag "Org Startup"
@@ -11694,6 +11713,18 @@ of `org-todo-keywords-1'."
 	     (org-occur (concat "^" org-outline-regexp " *" kwd-re )))))
 
 (defun org-deadline (&optional remove time)
+  "Insert the DEADLINE: string with a timestamp to schedule a TODO item.
+See `org-deadline-do' for details."
+  (interactive "P")
+  (if (or (not (org-region-active-p))
+          (not org-loop-over-headlines-in-active-region))
+      (org-deadline-do remove time)
+    (org-map-entries
+     `(org-deadline-do ,remove ,time)
+     org-loop-over-headlines-in-active-region
+     'region)))
+
+(defun org-deadline-do (&optional remove time)
   "Insert the \"DEADLINE:\" string with a timestamp to make a deadline.
 With argument REMOVE, remove any deadline from the item.
 With argument TIME, set the deadline at the corresponding date.  TIME
@@ -11735,6 +11766,18 @@ can either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
 
 (defun org-schedule (&optional remove time)
   "Insert the SCHEDULED: string with a timestamp to schedule a TODO item.
+See `org-schedule-do' for details."
+  (interactive "P")
+  (if (or (not (org-region-active-p))
+          (not org-loop-over-headlines-in-active-region))
+      (org-schedule-do remove time)
+    (org-map-entries
+     `(org-schedule-do ,remove ,time)
+     org-loop-over-headlines-in-active-region
+     'region)))
+
+(defun org-schedule-do (&optional remove time)
+  "Insert the SCHEDULED: string with a timestamp to schedule a TODO item.
 With argument REMOVE, remove any scheduling date from the item.
 With argument TIME, scheduled at the corresponding date.  TIME can
 either be an Org date like \"2011-07-24\" or a delta like \"+2d\"."
@@ -13518,7 +13561,8 @@ a *different* entry, you cannot use these techniques."
 	       (org-narrow-to-subtree)
 	       (setq scope nil))
 	      ((and (eq scope 'region) (org-region-active-p))
-	       (narrow-to-region (region-beginning) (region-end))
+	       (narrow-to-region (region-beginning) 
+				 (org-end-of-subtree t))
 	       (setq scope nil)))
 
 	(if (not scope)
-- 
1.7.5.2


[-- Attachment #5: Type: text/plain, Size: 14 bytes --]


-- 
 Bastien