New feature: allow some commands to loop over siblings.

This commit introduce `org-loop-over-siblings-within-active-region-p'
as a new defcustom that you can turn on (`non-nil') to allow commands
to loop over siblings in the active region.

The list of commands is this:

- org-archive-subtree
- org-archive-to-archive-sibling
- org-toggle-archive-tag
- org-deadline
- org-schedule

When `org-loop-over-siblings-within-active-region-p' is `non-nil' and
you run one of the command above on a region containing several headlines,
then Org will apply the command to each headline.

This can be particularily useful for archiving several headlines, or to
add a deadline or schedule several entries.

* org.el (org-loop-over-siblings-within-active-region-p): New
defcustom so that `org-loop-over-siblings-in-active-region'
can be turned on and off.
(org-deadline, org-schedule): Use the new macro.

* org-macs.el (org-loop-over-siblings-in-active-region): New
macro to let some commands act upon several siblings in the
active region.

* org-archive.el (org-archive-subtree)
(org-archive-to-archive-sibling, org-toggle-archive-tag): Use
`org-loop-over-siblings-in-active-region'.

lisp/org-archive.el

@@ -190,6 +190,7 @@ 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
@@ -326,8 +327,7 @@ this heading."
 	   
 	   ;; Save and kill the buffer, if it is not the same buffer.
 	   (when (not (eq this-buffer buffer))
-	    (save-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))
@@ -340,7 +340,7 @@ this heading."
 		  (concat "in file: " (abbreviate-file-name afile))))))
    (org-reveal)
    (if (looking-at "^[ \t]*$")
-      (outline-next-visible-heading 1)))
+       (outline-next-visible-heading 1))))
 
 (defun org-archive-to-archive-sibling ()
   "Archive the current heading by moving it under the archive sibling.
@@ -348,11 +348,12 @@ 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 org-outline-regexp)
+       (looking-at outline-regexp)
        (setq leader (match-string 0)
 	     level (funcall outline-level))
        (setq pos (point))
@@ -396,7 +397,7 @@ sibling does not exist, it will be created at the end of the subtree."
        (goto-char pos)))
    (org-reveal)
    (if (looking-at "^[ \t]*$")
-      (outline-next-visible-heading 1)))
+       (outline-next-visible-heading 1))))
 
 (defun org-archive-all-done (&optional tag)
   "Archive sublevels of the current tree without open TODO items.
@@ -447,6 +448,7 @@ 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)
@@ -455,7 +457,7 @@ the children that do not contain any open TODO items."
 	 (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")))))
+       (message "Subtree %s" (if set "archived" "unarchived"))))))
 
 (defun org-archive-set-tag ()
   "Set the ARCHIVE tag."

lisp/org-macs.el

@@ -367,6 +367,26 @@ 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

lisp/org.el

@@ -1971,12 +1971,22 @@ heading."
   :group 'org-time)
 
 (defvar org-todo-interpretation-widgets
-  '(
-    (:tag "Sequence (cycling hits every state)" sequence)
+  '((:tag "Sequence (cycling hits every state)" sequence)
     (:tag "Type     (cycling directly to DONE)" type))
   "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'"
+  :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.
@@ -11664,6 +11674,7 @@ With argument REMOVE, remove any deadline from the item.
 When TIME is set, it should be an internal time specification, and the
 scheduling will use the corresponding date."
   (interactive "P")
+  (org-loop-over-siblings-in-active-region
    (let* ((old-date (org-entry-get nil "DEADLINE"))
 	  (repeater (and old-date
 			 (string-match
@@ -11696,7 +11707,7 @@ scheduling will use the corresponding date."
 		   (concat (substring org-last-inserted-timestamp 0 -1)
 			   " " repeater
 			   (substring org-last-inserted-timestamp -1))))))
-      (message "Deadline on %s" org-last-inserted-timestamp))))
+       (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.
@@ -11704,6 +11715,7 @@ With argument REMOVE, remove any scheduling date from the item.
 When TIME is set, it should be an internal time specification, and the
 scheduling will use the corresponding date."
   (interactive "P")
+  (org-loop-over-siblings-in-active-region
    (let* ((old-date (org-entry-get nil "SCHEDULED"))
 	  (repeater (and old-date
 			 (string-match
@@ -11736,7 +11748,7 @@ scheduling will use the corresponding date."
 		   (concat (substring org-last-inserted-timestamp 0 -1)
 			   " " repeater
 			   (substring org-last-inserted-timestamp -1))))))
-      (message "Scheduled to %s" org-last-inserted-timestamp))))
+       (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