From f35c6615a575ab5aec6e1a153c6c1748619b46c5 Mon Sep 17 00:00:00 2001 From: Carsten Dominik Date: Fri, 18 Apr 2008 09:50:50 +0200 Subject: [PATCH] Clocktables including archives. --- doc/org.texi | 2 + lisp/org-archive.el | 89 ++++++++++++++++++++++++++++++++++----------- lisp/org-clock.el | 34 +++++++++++------ lisp/org.el | 29 ++------------- 4 files changed, 96 insertions(+), 58 deletions(-) diff --git a/doc/org.texi b/doc/org.texi index b0202541c..2db08b332 100644 --- a/doc/org.texi +++ b/doc/org.texi @@ -4542,6 +4542,8 @@ new table. The @samp{BEGIN} line can specify options: tree @r{the surrounding level 1 tree} agenda @r{all agenda files} ("file"..) @r{scan these files} + file-with-archives @r{current file and its archives} + agenda-with-archives @r{all agenda files, including archives} :block @r{The time block to consider. This block is specified either} @r{absolute, or relative to the current time and may be any of} @r{these formats:} diff --git a/lisp/org-archive.el b/lisp/org-archive.el index c20b2a5d8..2dd63a307 100644 --- a/lisp/org-archive.el +++ b/lisp/org-archive.el @@ -87,6 +87,64 @@ information." (const :tag "Outline path" olpath) (const :tag "Local tags" ltags))) +(defun org-get-local-archive-location () + "Get the archive location applicable at point." + (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") + prop) + (save-excursion + (save-restriction + (widen) + (setq prop (org-entry-get nil "ARCHIVE" 'inherit)) + (cond + ((and prop (string-match "\\S-" prop)) + prop) + ((or (re-search-backward re nil t) + (re-search-forward re nil t)) + (match-string 1)) + (t org-archive-location (match-string 1))))))) + +(defun org-add-archive-files (files) + "Splice the archive files into the list f files. +This implies visiting all these files and finding out what the +archive file is." + (apply + 'append + (mapcar + (lambda (f) + (if (not (file-exists-p f)) + nil + (with-current-buffer (org-get-agenda-file-buffer f) + (cons f (org-all-archive-files))))) + files))) + +(defun org-all-archive-files () + "Get a list of all archive files used in the current buffer." + (let (file files) + (save-excursion + (save-restriction + (goto-char (point-min)) + (while (re-search-forward + "^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)" + nil t) + (setq file (org-extract-archive-file (match-string 2))) + (and file (> (length file) 0) (file-exists-p file) + (add-to-list 'files file))))) + (setq files (nreverse files)) + (setq file (org-extract-archive-file)) + (and file (> (length file) 0) (file-exists-p file) + (add-to-list 'files file)) + files)) + +(defun org-extract-archive-file (&optional location) + (setq location (or location org-archive-location)) + (if (string-match "\\(.*\\)::\\(.*\\)" location) + (format (match-string 1 location) buffer-file-name))) + +(defun org-extract-archive-heading (&optional location) + (setq location (or location org-archive-location)) + (if (string-match "\\(.*\\)::\\(.*\\)" location) + (match-string 2 location))) + (defun org-archive-subtree (&optional find-done) "Move the current subtree to the archive. The archive can be a certain top-level heading in the current file, or in @@ -111,8 +169,6 @@ this heading." (tr-org-todo-line-regexp org-todo-line-regexp) (tr-org-odd-levels-only org-odd-levels-only) (this-buffer (current-buffer)) - (org-archive-location org-archive-location) - (re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") ;; start of variables that will be used for saving context ;; The compiler complains about them - keep them anyway! (file (abbreviate-file-name (buffer-file-name))) @@ -120,28 +176,17 @@ this heading." (time (format-time-string (substring (cdr org-time-stamp-formats) 1 -1) (current-time))) - afile heading buffer level newfile-p - category todo priority - ;; start of variables that will be used for savind context - ltags itags prop) + category todo priority ltags itags + ;; end of variables that will be used for saving context + location afile heading buffer level newfile-p) - ;; Try to find a local archive location - (save-excursion - (save-restriction - (widen) - (setq prop (org-entry-get nil "ARCHIVE" 'inherit)) - (if (and prop (string-match "\\S-" prop)) - (setq org-archive-location prop) - (if (or (re-search-backward re nil t) - (re-search-forward re nil t)) - (setq org-archive-location (match-string 1)))))) - - (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location) - (progn - (setq afile (format (match-string 1 org-archive-location) - (file-name-nondirectory buffer-file-name)) - heading (match-string 2 org-archive-location))) + ;; Find the local archive location + (setq location (org-get-local-archive-location) + afile (org-extract-archive-file location) + heading (org-extract-archive-heading location)) + (unless afile (error "Invalid `org-archive-location'")) + (if (> (length afile) 0) (setq newfile-p (not (file-exists-p afile)) buffer (find-file-noselect afile)) diff --git a/lisp/org-clock.el b/lisp/org-clock.el index 29f55a55d..6f7968694 100644 --- a/lisp/org-clock.el +++ b/lisp/org-clock.el @@ -592,7 +592,7 @@ the currently selected interval size." (block (plist-get params :block)) (link (plist-get params :link)) ipos time p level hlc hdl - cc beg end pos tbl tbl1 range-text) + cc beg end pos tbl tbl1 range-text rm-file-column) (setq org-clock-file-total-minutes nil) (when step (org-clocktable-steps params) @@ -616,8 +616,17 @@ the currently selected interval size." ;; Get the right scope (setq pos (point)) - (if (and scope (listp scope) (symbolp (car scope))) - (setq scope (eval scope))) + (cond + ((and scope (listp scope) (symbolp (car scope))) + (setq scope (eval scope))) + ((eq scope 'agenda) + (setq scope (org-agenda-files t))) + ((eq scope 'agenda-with-archives) + (setq scope (org-agenda-files t)) + (setq scope (org-add-archive-files scope))) + ((eq scope 'file-with-archives) + (setq scope (org-add-archive-files (list (buffer-file-name))) + rm-file-column t))) (save-restriction (cond ((not scope)) @@ -635,8 +644,8 @@ the currently selected interval size." (if (<= (org-reduced-level (funcall outline-level)) level) (throw 'exit nil)))) (org-narrow-to-subtree)) - ((or (listp scope) (eq scope 'agenda)) - (let* ((files (if (listp scope) scope (org-agenda-files t))) + ((listp scope) + (let* ((files scope) (scope 'agenda) (p1 (copy-sequence params)) file) @@ -649,7 +658,7 @@ the currently selected interval size." (setq tbl1 (org-dblock-write:clocktable p1)) (when tbl1 (push (org-clocktable-add-file - file + file (concat "| |*File time*|*" (org-minutes-to-hh:mm-string org-clock-file-total-minutes) @@ -659,7 +668,7 @@ the currently selected interval size." org-clock-file-total-minutes)))))))) (goto-char pos) - (unless (or (eq scope 'agenda) (listp scope)) + (unless (listp scope) (org-clock-sum ts te) (goto-char (point-min)) (while (setq p (next-single-property-change (point) :org-clock-minutes)) @@ -701,12 +710,12 @@ the currently selected interval size." "]" (if block (concat ", for " range-text ".") "") "\n\n")) - (if (or (eq scope 'agenda) (listp scope)) "|File" "") + (if (listp scope) "|File" "") "|L|Headline|Time|\n") (setq total-time (or total-time org-clock-file-total-minutes)) (insert-before-markers "|-\n|" - (if (or (eq scope 'agenda) (listp scope)) "|" "") + (if (listp scope) "|" "") "|" "*Total time*| *" (org-minutes-to-hh:mm-string (or total-time 0)) @@ -717,11 +726,14 @@ the currently selected interval size." (pop tbl)) (insert-before-markers (mapconcat 'identity (delq nil tbl) - (if (eq scope 'agenda) "\n|-\n" "\n"))) + (if (listp scope) "\n|-\n" "\n"))) (backward-delete-char 1) (goto-char ipos) (skip-chars-forward "^|") - (org-table-align)))))) + (org-table-align) + (when rm-file-column + (forward-char 1) + (org-table-delete-column))))))) (defun org-clocktable-steps (params) (let* ((p1 (copy-sequence params)) diff --git a/lisp/org.el b/lisp/org.el index c8a3a0200..2a3bdb6dd 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -2532,8 +2532,10 @@ collapsed state." (defalias 'org-advertized-archive-subtree 'org-archive-subtree) -(org-autoload "org-archive" - '(org-archive-subtree org-archive-to-archive-sibling org-toggle-archive-tag)) +(eval-and-compile + (org-autoload "org-archive" + '(org-add-archive-files org-archive-subtree + org-archive-to-archive-sibling org-toggle-archive-tag))) ;; Autoload Column View Code @@ -12882,29 +12884,6 @@ really on, so that the block visually is on the match." (mapcar (lambda (x) (or (get-file-buffer x) (find-file-noselect x))) files) regexp))) -(defun org-add-archive-files (files) - "Splice the archive files into the list f files. -This implies visiting all these files and finding out what the -archive file is." - (let (afile) - (apply - 'append - (mapcar - (lambda (f) - (if (not (file-exists-p f)) - nil - (with-current-buffer (or (get-file-buffer f) - (find-file-noselect f)) - - (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location) - (setq afile (format (match-string 1 org-archive-location) - buffer-file-name)) - (setq afile nil)) - (if (and afile (file-exists-p afile)) - (list f afile) - (list f))))) - files)))) - (if (boundp 'occur-mode-find-occurrence-hook) ;; Emacs 23 (add-hook 'occur-mode-find-occurrence-hook