From mboxrd@z Thu Jan 1 00:00:00 1970 From: Toby Cubitt Subject: Re: [PATCH] Selectively archive by timestamp Date: Tue, 16 Dec 2014 22:48:42 +0000 Message-ID: <20141216224842.GA3521@c3po> References: <87388f5kl2.fsf@nicolasgoaziou.fr> Reply-To: Toby Cubitt Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="Dxnq1zWXvFF0Q93v" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:47885) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1Y10vH-0004ij-S6 for emacs-orgmode@gnu.org; Tue, 16 Dec 2014 17:49:00 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1Y10vA-0005RP-8N for emacs-orgmode@gnu.org; Tue, 16 Dec 2014 17:48:55 -0500 Received: from sanddollar.geekisp.com ([216.168.135.167]:25736) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1Y10vA-0005RF-2s for emacs-orgmode@gnu.org; Tue, 16 Dec 2014 17:48:48 -0500 Content-Disposition: inline In-Reply-To: <87388f5kl2.fsf@nicolasgoaziou.fr> List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org Cc: Nicolas Goaziou --Dxnq1zWXvFF0Q93v Content-Type: text/plain; charset=us-ascii Content-Disposition: inline On Tue, Dec 16, 2014 at 10:52:09PM +0100, Nicolas Goaziou wrote: > Toby Cubitt 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 --Dxnq1zWXvFF0Q93v Content-Type: text/x-patch; charset=us-ascii Content-Disposition: attachment; filename="0001-org-archive.el-Add-command-to-archive-entries-with-t.patch" >From e4ad9035f2fe50d2f4272621453bf5761c5802fa Mon Sep 17 00:00:00 2001 From: "Toby S. Cubitt" 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 --Dxnq1zWXvFF0Q93v--