* Selectively archive by timestamp
@ 2014-09-29 14:16 Toby Cubitt
2014-12-12 20:34 ` [PATCH] " Toby Cubitt
0 siblings, 1 reply; 8+ messages in thread
From: Toby Cubitt @ 2014-09-29 14:16 UTC (permalink / raw)
To: emacs-orgmode
[-- Attachment #1: Type: text/plain, Size: 748 bytes --]
Sometimes I want to selectively archive all entries in a subtree with
timestamps in the past, whilst keeping all entries with timestamps in the
future.
`org-archive-subtree' only lets you selectively archive entries depending
on whether they have open TODO items.
The attached patch adds a new `org-archive-all-old' counterpart to
`org-archive-all-done' which does timestamp-selective archiving. It also
extends `org-archive-subtree' so it can optionally be invoked for
timestamp-based archiving instead of TODO-based archiving.
Toby
--
Dr T. S. Cubitt
Royal Society University Research Fellow
Fellow of Churchill College, Cambridge
Centre for Quantum Information
DAMTP, University of Cambridge
email: tsc25@cantab.net
web: www.dr-qubit.org
[-- Attachment #2: 0001-Add-org-archive-all-old-to-archive-entries-with-time.patch --]
[-- Type: text/x-patch, Size: 6032 bytes --]
From 3183bcf9c005a0d5633dcc8be1719e55e3dfa8c5 Mon Sep 17 00:00:00 2001
From: "Toby S. Cubitt" <tsc25@cantab.net>
Date: Fri, 17 Jan 2014 15:14:13 +0000
Subject: [PATCH] Add org-archive-all-old to archive entries with timestamps
before today.
Can be invoked from org-archive-subtree command with double prefix-arg.
---
doc/org.texi | 4 ++++
lisp/org-archive.el | 68 +++++++++++++++++++++++++++++++++++++++++++----------
2 files changed, 60 insertions(+), 12 deletions(-)
diff --git a/doc/org.texi b/doc/org.texi
index 7d98d51..d2e61a8 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -7469,6 +7469,10 @@ the archive. To do this, each subtree is checked for open TODO entries.
If none are found, the command offers to move it to the archive
location. If the cursor is @emph{not} on a headline when this command
is invoked, the level 1 trees will be checked.
+@orgkey{C-u C-u C-c C-x C-s}
+As above, but check subtree for timestamps instead of TODO entries. The
+command will offer to archive the subtree if it @emph{does} contain a
+timestamp, and that timestamp is in the past.
@end table
@cindex archive locations
diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 700e59b..418af3a 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -198,9 +198,11 @@ The archive can be a certain top-level heading in the current file, or in
a different file. The tree will be moved to that location, the subtree
heading be marked DONE, and the current time will be added.
-When called with prefix argument FIND-DONE, find whole trees without any
+When called with a single prefix argument FIND-DONE, find whole trees without any
open TODO items and archive them (after getting confirmation from the user).
-If the cursor is not at a headline when this command is called, try all level
+When called with a double prefix argument, find whole trees with timestamps before
+today and archive them (after getting confirmation from the user).
+If the cursor is not at a headline when these commands are called, try all level
1 trees. If the cursor is on a headline, only try the direct children of
this heading."
(interactive "P")
@@ -213,8 +215,10 @@ this heading."
(org-archive-subtree ,find-done))
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
- (if find-done
- (org-archive-all-done)
+ (cond
+ ((equal find-done '(4)) (org-archive-all-done))
+ ((equal find-done '(16)) (org-archive-all-old))
+ (t
;; 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)
@@ -375,7 +379,7 @@ this heading."
(message "Subtree archived %s"
(if (eq this-buffer buffer)
(concat "under heading: " heading)
- (concat "in file: " (abbreviate-file-name afile))))))
+ (concat "in file: " (abbreviate-file-name afile)))))))
(org-reveal)
(if (looking-at "^[ \t]*$")
(outline-next-visible-heading 1))))
@@ -456,13 +460,50 @@ sibling does not exist, it will be created at the end of the subtree."
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
- (let ((re org-not-done-heading-regexp) re1
- (rea (concat ".*:" org-archive-tag ":"))
+ (org-archive-all-matches
+ (lambda (beg end)
+ (unless (re-search-forward org-not-done-heading-regexp end t)
+ "no open TODO items"))
+ tag))
+
+(defun org-archive-all-old (&optional tag)
+ "Archive sublevels of the current tree with timestamps prior to today.
+If the cursor is not on a headline, try all level 1 trees. If
+it is on a headline, try all direct children.
+When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
+ (org-archive-all-matches
+ (lambda (beg end)
+ (let (ts)
+ (and (re-search-forward org-ts-regexp end t)
+ (setq ts (match-string 0))
+ (< (org-time-stamp-to-now ts) 0)
+ (if (not (looking-at
+ (concat "--\\(" org-ts-regexp "\\)")))
+ (concat "old timestamp " ts)
+ (setq ts (concat "old timestamp " ts (match-string 0)))
+ (and (< (org-time-stamp-to-now (match-string 1)) 0)
+ ts)))))
+ tag))
+
+(defun org-archive-all-matches (predicate &optional tag)
+ "Archive sublevels of the current tree that match PREDICATE.
+
+PREDICATE is a function of two arguments, BEG and END, which
+specify the beginning and end of the headline being considered.
+It is called with point positioned at BEG. The headline will be
+archived if PREDICATE returns non-nil. If the return value of
+PREDICATE is a string, it should describe the reason for
+archiving the heading.
+
+If the cursor is not on a headline, try all level 1 trees. If it
+is on a headline, try all direct children. When TAG is non-nil,
+don't move trees, but mark them with the ARCHIVE tag."
+ (let ((rea (concat ".*:" org-archive-tag ":")) re1
(begm (make-marker))
(endm (make-marker))
- (question (if tag "Set ARCHIVE tag (no open TODO items)? "
- "Move subtree to archive (no open TODO items)? "))
- beg end (cntarch 0))
+ (question (if tag "Set ARCHIVE tag? "
+ "Move subtree to archive? "))
+ reason beg end (cntarch 0))
(if (org-at-heading-p)
(progn
(setq re1 (concat "^" (regexp-quote
@@ -482,11 +523,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(setq beg (match-beginning 0)
end (save-excursion (org-end-of-subtree t) (point)))
(goto-char beg)
- (if (re-search-forward re end t)
+ (if (not (setq reason (funcall predicate beg end)))
(goto-char end)
(goto-char beg)
(if (and (or (not tag) (not (looking-at rea)))
- (y-or-n-p question))
+ (y-or-n-p
+ (if (stringp reason)
+ (concat question "(" reason ")")
+ question)))
(progn
(if tag
(org-toggle-tag org-archive-tag 'on)
--
1.8.5.5
^ permalink raw reply related [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-09-29 14:16 Selectively archive by timestamp Toby Cubitt
@ 2014-12-12 20:34 ` Toby Cubitt
2014-12-13 14:23 ` Nicolas Goaziou
0 siblings, 1 reply; 8+ messages in thread
From: Toby Cubitt @ 2014-12-12 20:34 UTC (permalink / raw)
To: emacs-orgmode
Did this patch get lost in the noise?
It's a fairly straightforward one, which simply adds a useful new
archiving function without touching much else.
Archiving by date seems such an obvious omission from the existing
archiving commands, I wouldn't have thought this patch was too
controversial. (Unless someone doesn't like the choice of keybinding, in
which case by all means change it!)
Best,
Toby
On Mon, Sep 29, 2014 at 08:27:35PM +0100, Toby Cubitt wrote:
> Sometimes I want to selectively archive all entries in a subtree with
> timestamps in the past, whilst keeping all entries with timestamps in the
> future.
>
> `org-archive-subtree' only lets you selectively archive entries depending
> on whether they have open TODO items.
>
> The attached patch adds a new `org-archive-all-old' counterpart to
> `org-archive-all-done' which does timestamp-selective archiving. It also
> extends `org-archive-subtree' so it can optionally be invoked for
> timestamp-based archiving instead of TODO-based archiving.
>
> Toby
> >From 3183bcf9c005a0d5633dcc8be1719e55e3dfa8c5 Mon Sep 17 00:00:00 2001
> From: "Toby S. Cubitt" <tsc25@cantab.net>
> Date: Fri, 17 Jan 2014 15:14:13 +0000
> Subject: [PATCH] Add org-archive-all-old to archive entries with timestamps
> before today.
>
> Can be invoked from org-archive-subtree command with double prefix-arg.
> ---
> doc/org.texi | 4 ++++
> lisp/org-archive.el | 68 +++++++++++++++++++++++++++++++++++++++++++----------
> 2 files changed, 60 insertions(+), 12 deletions(-)
>
> diff --git a/doc/org.texi b/doc/org.texi
> index 7d98d51..d2e61a8 100644
> --- a/doc/org.texi
> +++ b/doc/org.texi
> @@ -7469,6 +7469,10 @@ the archive. To do this, each subtree is checked for open TODO entries.
> If none are found, the command offers to move it to the archive
> location. If the cursor is @emph{not} on a headline when this command
> is invoked, the level 1 trees will be checked.
> +@orgkey{C-u C-u C-c C-x C-s}
> +As above, but check subtree for timestamps instead of TODO entries. The
> +command will offer to archive the subtree if it @emph{does} contain a
> +timestamp, and that timestamp is in the past.
> @end table
>
> @cindex archive locations
> diff --git a/lisp/org-archive.el b/lisp/org-archive.el
> index 700e59b..418af3a 100644
> --- a/lisp/org-archive.el
> +++ b/lisp/org-archive.el
> @@ -198,9 +198,11 @@ The archive can be a certain top-level heading in the current file, or in
> a different file. The tree will be moved to that location, the subtree
> heading be marked DONE, and the current time will be added.
>
> -When called with prefix argument FIND-DONE, find whole trees without any
> +When called with a single prefix argument FIND-DONE, find whole trees without any
> open TODO items and archive them (after getting confirmation from the user).
> -If the cursor is not at a headline when this command is called, try all level
> +When called with a double prefix argument, find whole trees with timestamps before
> +today and archive them (after getting confirmation from the user).
> +If the cursor is not at a headline when these commands are called, try all level
> 1 trees. If the cursor is on a headline, only try the direct children of
> this heading."
> (interactive "P")
> @@ -213,8 +215,10 @@ this heading."
> (org-archive-subtree ,find-done))
> org-loop-over-headlines-in-active-region
> cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
> - (if find-done
> - (org-archive-all-done)
> + (cond
> + ((equal find-done '(4)) (org-archive-all-done))
> + ((equal find-done '(16)) (org-archive-all-old))
> + (t
> ;; 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)
> @@ -375,7 +379,7 @@ this heading."
> (message "Subtree archived %s"
> (if (eq this-buffer buffer)
> (concat "under heading: " heading)
> - (concat "in file: " (abbreviate-file-name afile))))))
> + (concat "in file: " (abbreviate-file-name afile)))))))
> (org-reveal)
> (if (looking-at "^[ \t]*$")
> (outline-next-visible-heading 1))))
> @@ -456,13 +460,50 @@ sibling does not exist, it will be created at the end of the subtree."
> If the cursor is not on a headline, try all level 1 trees. If
> it is on a headline, try all direct children.
> When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
> - (let ((re org-not-done-heading-regexp) re1
> - (rea (concat ".*:" org-archive-tag ":"))
> + (org-archive-all-matches
> + (lambda (beg end)
> + (unless (re-search-forward org-not-done-heading-regexp end t)
> + "no open TODO items"))
> + tag))
> +
> +(defun org-archive-all-old (&optional tag)
> + "Archive sublevels of the current tree with timestamps prior to today.
> +If the cursor is not on a headline, try all level 1 trees. If
> +it is on a headline, try all direct children.
> +When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
> + (org-archive-all-matches
> + (lambda (beg end)
> + (let (ts)
> + (and (re-search-forward org-ts-regexp end t)
> + (setq ts (match-string 0))
> + (< (org-time-stamp-to-now ts) 0)
> + (if (not (looking-at
> + (concat "--\\(" org-ts-regexp "\\)")))
> + (concat "old timestamp " ts)
> + (setq ts (concat "old timestamp " ts (match-string 0)))
> + (and (< (org-time-stamp-to-now (match-string 1)) 0)
> + ts)))))
> + tag))
> +
> +(defun org-archive-all-matches (predicate &optional tag)
> + "Archive sublevels of the current tree that match PREDICATE.
> +
> +PREDICATE is a function of two arguments, BEG and END, which
> +specify the beginning and end of the headline being considered.
> +It is called with point positioned at BEG. The headline will be
> +archived if PREDICATE returns non-nil. If the return value of
> +PREDICATE is a string, it should describe the reason for
> +archiving the heading.
> +
> +If the cursor is not on a headline, try all level 1 trees. If it
> +is on a headline, try all direct children. When TAG is non-nil,
> +don't move trees, but mark them with the ARCHIVE tag."
> + (let ((rea (concat ".*:" org-archive-tag ":")) re1
> (begm (make-marker))
> (endm (make-marker))
> - (question (if tag "Set ARCHIVE tag (no open TODO items)? "
> - "Move subtree to archive (no open TODO items)? "))
> - beg end (cntarch 0))
> + (question (if tag "Set ARCHIVE tag? "
> + "Move subtree to archive? "))
> + reason beg end (cntarch 0))
> (if (org-at-heading-p)
> (progn
> (setq re1 (concat "^" (regexp-quote
> @@ -482,11 +523,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
> (setq beg (match-beginning 0)
> end (save-excursion (org-end-of-subtree t) (point)))
> (goto-char beg)
> - (if (re-search-forward re end t)
> + (if (not (setq reason (funcall predicate beg end)))
> (goto-char end)
> (goto-char beg)
> (if (and (or (not tag) (not (looking-at rea)))
> - (y-or-n-p question))
> + (y-or-n-p
> + (if (stringp reason)
> + (concat question "(" reason ")")
> + question)))
> (progn
> (if tag
> (org-toggle-tag org-archive-tag 'on)
--
Dr T. S. Cubitt
Royal Society University Research Fellow
Fellow of Churchill College, Cambridge
Centre for Quantum Information
DAMTP, University of Cambridge
email: tsc25@cantab.net
web: www.dr-qubit.org
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-12 20:34 ` [PATCH] " Toby Cubitt
@ 2014-12-13 14:23 ` Nicolas Goaziou
2014-12-16 16:02 ` Toby Cubitt
0 siblings, 1 reply; 8+ messages in thread
From: Nicolas Goaziou @ 2014-12-13 14:23 UTC (permalink / raw)
To: emacs-orgmode
Hello,
Toby Cubitt <tsc25@cantab.net> writes:
> Did this patch get lost in the noise?
Probably.
> It's a fairly straightforward one, which simply adds a useful new
> archiving function without touching much else.
>
> Archiving by date seems such an obvious omission from the existing
> archiving commands, I wouldn't have thought this patch was too
> controversial. (Unless someone doesn't like the choice of keybinding, in
> which case by all means change it!)
Looks good. Could you send it again so I can apply it?
Regards,
--
Nicolas Goaziou
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-13 14:23 ` Nicolas Goaziou
@ 2014-12-16 16:02 ` Toby Cubitt
2014-12-16 21:52 ` Nicolas Goaziou
0 siblings, 1 reply; 8+ messages in thread
From: Toby Cubitt @ 2014-12-16 16:02 UTC (permalink / raw)
To: emacs-orgmode; +Cc: Nicolas Goaziou
[-- Attachment #1: Type: text/plain, Size: 759 bytes --]
On Sat, Dec 13, 2014 at 03:23:34PM +0100, Nicolas Goaziou wrote:
> > It's a fairly straightforward one, which simply adds a useful new
> > archiving function without touching much else.
> >
> > Archiving by date seems such an obvious omission from the existing
> > archiving commands, I wouldn't have thought this patch was too
> > controversial. (Unless someone doesn't like the choice of keybinding, in
> > which case by all means change it!)
>
> Looks good. Could you send it again so I can apply it?
Here it is again (attached).
Best,
Toby
--
Dr T. S. Cubitt
Royal Society University Research Fellow
Fellow of Churchill College, Cambridge
Centre for Quantum Information
DAMTP, University of Cambridge
email: tsc25@cantab.net
web: www.dr-qubit.org
[-- Attachment #2: 0001-Add-org-archive-all-old-to-archive-entries-with-time.patch --]
[-- Type: text/x-patch, Size: 6032 bytes --]
From 3183bcf9c005a0d5633dcc8be1719e55e3dfa8c5 Mon Sep 17 00:00:00 2001
From: "Toby S. Cubitt" <tsc25@cantab.net>
Date: Fri, 17 Jan 2014 15:14:13 +0000
Subject: [PATCH] Add org-archive-all-old to archive entries with timestamps
before today.
Can be invoked from org-archive-subtree command with double prefix-arg.
---
doc/org.texi | 4 ++++
lisp/org-archive.el | 68 +++++++++++++++++++++++++++++++++++++++++++----------
2 files changed, 60 insertions(+), 12 deletions(-)
diff --git a/doc/org.texi b/doc/org.texi
index 7d98d51..d2e61a8 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -7469,6 +7469,10 @@ the archive. To do this, each subtree is checked for open TODO entries.
If none are found, the command offers to move it to the archive
location. If the cursor is @emph{not} on a headline when this command
is invoked, the level 1 trees will be checked.
+@orgkey{C-u C-u C-c C-x C-s}
+As above, but check subtree for timestamps instead of TODO entries. The
+command will offer to archive the subtree if it @emph{does} contain a
+timestamp, and that timestamp is in the past.
@end table
@cindex archive locations
diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 700e59b..418af3a 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -198,9 +198,11 @@ The archive can be a certain top-level heading in the current file, or in
a different file. The tree will be moved to that location, the subtree
heading be marked DONE, and the current time will be added.
-When called with prefix argument FIND-DONE, find whole trees without any
+When called with a single prefix argument FIND-DONE, find whole trees without any
open TODO items and archive them (after getting confirmation from the user).
-If the cursor is not at a headline when this command is called, try all level
+When called with a double prefix argument, find whole trees with timestamps before
+today and archive them (after getting confirmation from the user).
+If the cursor is not at a headline when these commands are called, try all level
1 trees. If the cursor is on a headline, only try the direct children of
this heading."
(interactive "P")
@@ -213,8 +215,10 @@ this heading."
(org-archive-subtree ,find-done))
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
- (if find-done
- (org-archive-all-done)
+ (cond
+ ((equal find-done '(4)) (org-archive-all-done))
+ ((equal find-done '(16)) (org-archive-all-old))
+ (t
;; 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)
@@ -375,7 +379,7 @@ this heading."
(message "Subtree archived %s"
(if (eq this-buffer buffer)
(concat "under heading: " heading)
- (concat "in file: " (abbreviate-file-name afile))))))
+ (concat "in file: " (abbreviate-file-name afile)))))))
(org-reveal)
(if (looking-at "^[ \t]*$")
(outline-next-visible-heading 1))))
@@ -456,13 +460,50 @@ sibling does not exist, it will be created at the end of the subtree."
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
- (let ((re org-not-done-heading-regexp) re1
- (rea (concat ".*:" org-archive-tag ":"))
+ (org-archive-all-matches
+ (lambda (beg end)
+ (unless (re-search-forward org-not-done-heading-regexp end t)
+ "no open TODO items"))
+ tag))
+
+(defun org-archive-all-old (&optional tag)
+ "Archive sublevels of the current tree with timestamps prior to today.
+If the cursor is not on a headline, try all level 1 trees. If
+it is on a headline, try all direct children.
+When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
+ (org-archive-all-matches
+ (lambda (beg end)
+ (let (ts)
+ (and (re-search-forward org-ts-regexp end t)
+ (setq ts (match-string 0))
+ (< (org-time-stamp-to-now ts) 0)
+ (if (not (looking-at
+ (concat "--\\(" org-ts-regexp "\\)")))
+ (concat "old timestamp " ts)
+ (setq ts (concat "old timestamp " ts (match-string 0)))
+ (and (< (org-time-stamp-to-now (match-string 1)) 0)
+ ts)))))
+ tag))
+
+(defun org-archive-all-matches (predicate &optional tag)
+ "Archive sublevels of the current tree that match PREDICATE.
+
+PREDICATE is a function of two arguments, BEG and END, which
+specify the beginning and end of the headline being considered.
+It is called with point positioned at BEG. The headline will be
+archived if PREDICATE returns non-nil. If the return value of
+PREDICATE is a string, it should describe the reason for
+archiving the heading.
+
+If the cursor is not on a headline, try all level 1 trees. If it
+is on a headline, try all direct children. When TAG is non-nil,
+don't move trees, but mark them with the ARCHIVE tag."
+ (let ((rea (concat ".*:" org-archive-tag ":")) re1
(begm (make-marker))
(endm (make-marker))
- (question (if tag "Set ARCHIVE tag (no open TODO items)? "
- "Move subtree to archive (no open TODO items)? "))
- beg end (cntarch 0))
+ (question (if tag "Set ARCHIVE tag? "
+ "Move subtree to archive? "))
+ reason beg end (cntarch 0))
(if (org-at-heading-p)
(progn
(setq re1 (concat "^" (regexp-quote
@@ -482,11 +523,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(setq beg (match-beginning 0)
end (save-excursion (org-end-of-subtree t) (point)))
(goto-char beg)
- (if (re-search-forward re end t)
+ (if (not (setq reason (funcall predicate beg end)))
(goto-char end)
(goto-char beg)
(if (and (or (not tag) (not (looking-at rea)))
- (y-or-n-p question))
+ (y-or-n-p
+ (if (stringp reason)
+ (concat question "(" reason ")")
+ question)))
(progn
(if tag
(org-toggle-tag org-archive-tag 'on)
--
1.8.5.5
^ permalink raw reply related [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-16 16:02 ` Toby Cubitt
@ 2014-12-16 21:52 ` Nicolas Goaziou
2014-12-16 22:48 ` Toby Cubitt
0 siblings, 1 reply; 8+ messages in thread
From: Nicolas Goaziou @ 2014-12-16 21:52 UTC (permalink / raw)
To: emacs-orgmode
Toby Cubitt <tsc25@cantab.net> writes:
> Here it is again (attached).
Thank you. However, could you provide an appropriate commit message
(functions modified, reason...)?
Sorry for not catching that earlier.
Regards,
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-16 21:52 ` Nicolas Goaziou
@ 2014-12-16 22:48 ` Toby Cubitt
2014-12-16 23:09 ` Nicolas Goaziou
2014-12-16 23:38 ` Nicolas Goaziou
0 siblings, 2 replies; 8+ messages in thread
From: Toby Cubitt @ 2014-12-16 22:48 UTC (permalink / raw)
To: emacs-orgmode; +Cc: Nicolas Goaziou
[-- Attachment #1: Type: text/plain, Size: 614 bytes --]
On Tue, Dec 16, 2014 at 10:52:09PM +0100, Nicolas Goaziou wrote:
> Toby Cubitt <tsc25@cantab.net> writes:
>
> > Here it is again (attached).
>
> Thank you. However, could you provide an appropriate commit message
> (functions modified, reason...)?
>
> Sorry for not catching that earlier.
Sorry, not sure why I forgot to do that. Here's an updated version with
suitable commit message.
Best,
Toby
--
Dr T. S. Cubitt
Royal Society University Research Fellow
Fellow of Churchill College, Cambridge
Centre for Quantum Information
DAMTP, University of Cambridge
email: tsc25@cantab.net
web: www.dr-qubit.org
[-- Attachment #2: 0001-org-archive.el-Add-command-to-archive-entries-with-t.patch --]
[-- Type: text/x-patch, Size: 6246 bytes --]
From e4ad9035f2fe50d2f4272621453bf5761c5802fa Mon Sep 17 00:00:00 2001
From: "Toby S. Cubitt" <tsc25@cantab.net>
Date: Fri, 17 Jan 2014 15:14:13 +0000
Subject: [PATCH] org-archive.el: Add command to archive entries with
timestamps before today.
* lisp/org-archive.el (org-archive-all-old): archive all entries with
timestamps prior to today.
(org-archive-subtree): double prefix argument invokes
org-archive-all-old.
(org-archive-all-matches, org-archive-all-done): factor out common
code into org-archive-all-matches.
---
doc/org.texi | 4 ++++
lisp/org-archive.el | 68 +++++++++++++++++++++++++++++++++++++++++++----------
2 files changed, 60 insertions(+), 12 deletions(-)
diff --git a/doc/org.texi b/doc/org.texi
index d617259..10463ff 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -7512,6 +7512,10 @@ the archive. To do this, each subtree is checked for open TODO entries.
If none are found, the command offers to move it to the archive
location. If the cursor is @emph{not} on a headline when this command
is invoked, the level 1 trees will be checked.
+@orgkey{C-u C-u C-c C-x C-s}
+As above, but check subtree for timestamps instead of TODO entries. The
+command will offer to archive the subtree if it @emph{does} contain a
+timestamp, and that timestamp is in the past.
@end table
@cindex archive locations
diff --git a/lisp/org-archive.el b/lisp/org-archive.el
index 96ef021..3e14291 100644
--- a/lisp/org-archive.el
+++ b/lisp/org-archive.el
@@ -204,9 +204,11 @@ The archive can be a certain top-level heading in the current file, or in
a different file. The tree will be moved to that location, the subtree
heading be marked DONE, and the current time will be added.
-When called with prefix argument FIND-DONE, find whole trees without any
+When called with a single prefix argument FIND-DONE, find whole trees without any
open TODO items and archive them (after getting confirmation from the user).
-If the cursor is not at a headline when this command is called, try all level
+When called with a double prefix argument, find whole trees with timestamps before
+today and archive them (after getting confirmation from the user).
+If the cursor is not at a headline when these commands are called, try all level
1 trees. If the cursor is on a headline, only try the direct children of
this heading."
(interactive "P")
@@ -219,8 +221,10 @@ this heading."
(org-archive-subtree ,find-done))
org-loop-over-headlines-in-active-region
cl (if (outline-invisible-p) (org-end-of-subtree nil t))))
- (if find-done
- (org-archive-all-done)
+ (cond
+ ((equal find-done '(4)) (org-archive-all-done))
+ ((equal find-done '(16)) (org-archive-all-old))
+ (t
;; 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)
@@ -383,7 +387,7 @@ this heading."
(message "Subtree archived %s"
(if (eq this-buffer buffer)
(concat "under heading: " heading)
- (concat "in file: " (abbreviate-file-name afile))))))
+ (concat "in file: " (abbreviate-file-name afile)))))))
(org-reveal)
(if (looking-at "^[ \t]*$")
(outline-next-visible-heading 1))))
@@ -464,13 +468,50 @@ sibling does not exist, it will be created at the end of the subtree."
If the cursor is not on a headline, try all level 1 trees. If
it is on a headline, try all direct children.
When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
- (let ((re org-not-done-heading-regexp) re1
- (rea (concat ".*:" org-archive-tag ":"))
+ (org-archive-all-matches
+ (lambda (beg end)
+ (unless (re-search-forward org-not-done-heading-regexp end t)
+ "no open TODO items"))
+ tag))
+
+(defun org-archive-all-old (&optional tag)
+ "Archive sublevels of the current tree with timestamps prior to today.
+If the cursor is not on a headline, try all level 1 trees. If
+it is on a headline, try all direct children.
+When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
+ (org-archive-all-matches
+ (lambda (beg end)
+ (let (ts)
+ (and (re-search-forward org-ts-regexp end t)
+ (setq ts (match-string 0))
+ (< (org-time-stamp-to-now ts) 0)
+ (if (not (looking-at
+ (concat "--\\(" org-ts-regexp "\\)")))
+ (concat "old timestamp " ts)
+ (setq ts (concat "old timestamp " ts (match-string 0)))
+ (and (< (org-time-stamp-to-now (match-string 1)) 0)
+ ts)))))
+ tag))
+
+(defun org-archive-all-matches (predicate &optional tag)
+ "Archive sublevels of the current tree that match PREDICATE.
+
+PREDICATE is a function of two arguments, BEG and END, which
+specify the beginning and end of the headline being considered.
+It is called with point positioned at BEG. The headline will be
+archived if PREDICATE returns non-nil. If the return value of
+PREDICATE is a string, it should describe the reason for
+archiving the heading.
+
+If the cursor is not on a headline, try all level 1 trees. If it
+is on a headline, try all direct children. When TAG is non-nil,
+don't move trees, but mark them with the ARCHIVE tag."
+ (let ((rea (concat ".*:" org-archive-tag ":")) re1
(begm (make-marker))
(endm (make-marker))
- (question (if tag "Set ARCHIVE tag (no open TODO items)? "
- "Move subtree to archive (no open TODO items)? "))
- beg end (cntarch 0))
+ (question (if tag "Set ARCHIVE tag? "
+ "Move subtree to archive? "))
+ reason beg end (cntarch 0))
(if (org-at-heading-p)
(progn
(setq re1 (concat "^" (regexp-quote
@@ -490,11 +531,14 @@ When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag."
(setq beg (match-beginning 0)
end (save-excursion (org-end-of-subtree t) (point)))
(goto-char beg)
- (if (re-search-forward re end t)
+ (if (not (setq reason (funcall predicate beg end)))
(goto-char end)
(goto-char beg)
(if (and (or (not tag) (not (looking-at rea)))
- (y-or-n-p question))
+ (y-or-n-p
+ (if (stringp reason)
+ (concat question "(" reason ")")
+ question)))
(progn
(if tag
(org-toggle-tag org-archive-tag 'on)
--
2.0.4
^ permalink raw reply related [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-16 22:48 ` Toby Cubitt
@ 2014-12-16 23:09 ` Nicolas Goaziou
2014-12-16 23:38 ` Nicolas Goaziou
1 sibling, 0 replies; 8+ messages in thread
From: Nicolas Goaziou @ 2014-12-16 23:09 UTC (permalink / raw)
To: emacs-orgmode
Toby Cubitt <tsc25@cantab.net> writes:
> Sorry, not sure why I forgot to do that. Here's an updated version with
> suitable commit message.
Applied. Thank you.
Regards,
^ permalink raw reply [flat|nested] 8+ messages in thread
* Re: [PATCH] Selectively archive by timestamp
2014-12-16 22:48 ` Toby Cubitt
2014-12-16 23:09 ` Nicolas Goaziou
@ 2014-12-16 23:38 ` Nicolas Goaziou
1 sibling, 0 replies; 8+ messages in thread
From: Nicolas Goaziou @ 2014-12-16 23:38 UTC (permalink / raw)
To: emacs-orgmode
Toby Cubitt <tsc25@cantab.net> writes:
> On Tue, Dec 16, 2014 at 10:52:09PM +0100, Nicolas Goaziou wrote:
>> Toby Cubitt <tsc25@cantab.net> writes:
>>
>> > Here it is again (attached).
>>
>> Thank you. However, could you provide an appropriate commit message
>> (functions modified, reason...)?
>>
>> Sorry for not catching that earlier.
>
> Sorry, not sure why I forgot to do that. Here's an updated version with
> suitable commit message.
BTW, would you mind also providing an entry in ORG-NEWS?
Thanks,
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2014-12-16 23:38 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2014-09-29 14:16 Selectively archive by timestamp Toby Cubitt
2014-12-12 20:34 ` [PATCH] " Toby Cubitt
2014-12-13 14:23 ` Nicolas Goaziou
2014-12-16 16:02 ` Toby Cubitt
2014-12-16 21:52 ` Nicolas Goaziou
2014-12-16 22:48 ` Toby Cubitt
2014-12-16 23:09 ` Nicolas Goaziou
2014-12-16 23:38 ` Nicolas Goaziou
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).