Commit | Line | Data |
---|---|---|
20908596 CD |
1 | ;;; org-clock.el --- The time clocking code for Org-mode |
2 | ||
3 | ;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Carsten Dominik <carsten at orgmode dot org> | |
6 | ;; Keywords: outlines, hypermedia, calendar, wp | |
7 | ;; Homepage: http://orgmode.org | |
8 | ;; Version: 6.02b | |
9 | ;; | |
10 | ;; This file is part of GNU Emacs. | |
11 | ;; | |
b1fc2b50 | 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
20908596 | 13 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
14 | ;; the Free Software Foundation, either version 3 of the License, or |
15 | ;; (at your option) any later version. | |
20908596 CD |
16 | |
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
20908596 CD |
24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
25 | ;; | |
26 | ;;; Commentary: | |
27 | ||
28 | ;; This file contains the time clocking code for Org-mode | |
29 | ||
30 | (require 'org) | |
31 | (eval-when-compile | |
32 | (require 'cl) | |
33 | (require 'calendar)) | |
34 | ||
35 | (declare-function calendar-absolute-from-iso "cal-iso" (&optional date)) | |
36 | ||
37 | (defgroup org-clock nil | |
38 | "Options concerning clocking working time in Org-mode." | |
39 | :tag "Org Clock" | |
40 | :group 'org-progress) | |
41 | ||
42 | (defcustom org-clock-into-drawer 2 | |
43 | "Should clocking info be wrapped into a drawer? | |
44 | When t, clocking info will always be inserted into a :CLOCK: drawer. | |
45 | If necessary, the drawer will be created. | |
46 | When nil, the drawer will not be created, but used when present. | |
47 | When an integer and the number of clocking entries in an item | |
48 | reaches or exceeds this number, a drawer will be created." | |
49 | :group 'org-todo | |
50 | :group 'org-clock | |
51 | :type '(choice | |
52 | (const :tag "Always" t) | |
53 | (const :tag "Only when drawer exists" nil) | |
54 | (integer :tag "When at least N clock entries"))) | |
55 | ||
56 | (defcustom org-clock-out-when-done t | |
57 | "When t, the clock will be stopped when the relevant entry is marked DONE. | |
58 | Nil means, clock will keep running until stopped explicitly with | |
59 | `C-c C-x C-o', or until the clock is started in a different item." | |
60 | :group 'org-clock | |
61 | :type 'boolean) | |
62 | ||
63 | (defcustom org-clock-out-remove-zero-time-clocks nil | |
64 | "Non-nil means, remove the clock line when the resulting time is zero." | |
65 | :group 'org-clock | |
66 | :type 'boolean) | |
67 | ||
68 | (defcustom org-clock-in-switch-to-state nil | |
69 | "Set task to a special todo state while clocking it. | |
70 | The value should be the state to which the entry should be switched." | |
71 | :group 'org-clock | |
72 | :group 'org-todo | |
73 | :type '(choice | |
74 | (const :tag "Don't force a state" nil) | |
75 | (string :tag "State"))) | |
76 | ||
77 | (defcustom org-clock-history-length 5 | |
78 | "Number of clock tasks to remember in history." | |
79 | :group 'org-clock | |
80 | :type 'integer) | |
81 | ||
82 | (defcustom org-clock-heading-function nil | |
83 | "When non-nil, should be a function to create `org-clock-heading'. | |
84 | This is the string shown in the mode line when a clock is running. | |
85 | The function is called with point at the beginning of the headline." | |
86 | :group 'org-clock | |
87 | :type 'function) | |
88 | ||
89 | ||
90 | ;;; The clock for measuring work time. | |
91 | ||
92 | (defvar org-mode-line-string "") | |
93 | (put 'org-mode-line-string 'risky-local-variable t) | |
94 | ||
95 | (defvar org-mode-line-timer nil) | |
96 | (defvar org-clock-heading "") | |
97 | (defvar org-clock-start-time "") | |
98 | ||
99 | (defvar org-clock-history nil | |
100 | "Marker pointing to the previous task teking clock time. | |
101 | This is used to find back to the previous task after interrupting work. | |
102 | When clocking into a task and the clock is currently running, this marker | |
103 | is moved to the position of the currently running task and continues | |
104 | to point there even after the task is clocked out.") | |
105 | ||
106 | (defvar org-clock-default-task (make-marker) | |
107 | "Marker pointing to the default task that should clock time. | |
108 | The clock can be made to switch to this task after clocking out | |
109 | of a different task.") | |
110 | ||
111 | (defvar org-clock-interrupted-task (make-marker) | |
112 | "Marker pointing to the default task that should clock time. | |
113 | The clock can be made to switch to this task after clocking out | |
114 | of a different task.") | |
115 | ||
116 | (defun org-clock-history-push (&optional pos buffer) | |
117 | "Push a marker to the clock history." | |
118 | (let ((m (move-marker (make-marker) (or pos (point)) buffer)) n l) | |
119 | (while (setq n (member m org-clock-history)) | |
120 | (move-marker (car n) nil)) | |
121 | (setq org-clock-history | |
122 | (delq nil | |
123 | (mapcar (lambda (x) (if (marker-buffer x) x nil)) | |
124 | org-clock-history))) | |
125 | (when (>= (setq l (length org-clock-history)) org-clock-history-length) | |
126 | (setq org-clock-history | |
127 | (nreverse | |
128 | (nthcdr (- l org-clock-history-length -1) | |
129 | (nreverse org-clock-history))))) | |
130 | (push m org-clock-history))) | |
131 | ||
132 | (defun org-clock-select-task (&optional prompt) | |
133 | "Select a task that recently was associated with clocking." | |
134 | (interactive) | |
135 | (let (sel-list rpl file task (i 0) s) | |
136 | (save-window-excursion | |
137 | (org-switch-to-buffer-other-window | |
138 | (get-buffer-create "*Clock Task Select*")) | |
139 | (erase-buffer) | |
140 | (when (marker-buffer org-clock-default-task) | |
141 | (insert (org-add-props "Default Task\n" nil 'face 'bold)) | |
142 | (setq s (org-clock-insert-selection-line ?d org-clock-default-task)) | |
143 | (push s sel-list)) | |
144 | (when (marker-buffer org-clock-interrupted-task) | |
145 | (insert (org-add-props "The task interrupted by starting the last one\n" nil 'face 'bold)) | |
146 | (setq s (org-clock-insert-selection-line ?i org-clock-interrupted-task)) | |
147 | (push s sel-list)) | |
148 | (when (marker-buffer org-clock-marker) | |
149 | (insert (org-add-props "Current Clocking Task\n" nil 'face 'bold)) | |
150 | (setq s (org-clock-insert-selection-line ?c org-clock-marker)) | |
151 | (push s sel-list)) | |
152 | (insert (org-add-props "Recent Tasks\n" nil 'face 'bold)) | |
153 | (mapc | |
154 | (lambda (m) | |
155 | (when (marker-buffer m) | |
156 | (setq i (1+ i) | |
157 | s (org-clock-insert-selection-line | |
158 | (string-to-char (number-to-string i)) m)) | |
159 | (push s sel-list))) | |
160 | org-clock-history) | |
161 | (shrink-window-if-larger-than-buffer) | |
162 | (message (or prompt "Select task for clocking:")) | |
163 | (setq rpl (read-char-exclusive)) | |
164 | (cond | |
165 | ((eq rpl ?q) nil) | |
166 | ((eq rpl ?x) nil) | |
167 | ((assoc rpl sel-list) (cdr (assoc rpl sel-list))) | |
168 | (t (error "Invalid task choice %c" rpl)))))) | |
169 | ||
170 | (defun org-clock-insert-selection-line (i marker) | |
171 | (when (marker-buffer marker) | |
172 | (let (file cat task) | |
173 | (with-current-buffer (marker-buffer marker) | |
174 | (save-excursion | |
175 | (goto-char marker) | |
176 | (setq file (buffer-file-name (marker-buffer marker)) | |
177 | cat (or (org-get-category) | |
178 | (progn (org-refresh-category-properties) | |
179 | (org-get-category))) | |
180 | task (org-get-heading 'notags)))) | |
181 | (when (and cat task) | |
182 | (insert (format "[%c] %-15s %s\n" i cat task)) | |
183 | (cons i marker))))) | |
184 | ||
185 | (defun org-update-mode-line () | |
186 | (let* ((delta (- (time-to-seconds (current-time)) | |
187 | (time-to-seconds org-clock-start-time))) | |
188 | (h (floor delta 3600)) | |
189 | (m (floor (- delta (* 3600 h)) 60))) | |
190 | (setq org-mode-line-string | |
191 | (propertize (format "-[%d:%02d (%s)]" h m org-clock-heading) | |
192 | 'help-echo "Org-mode clock is running")) | |
193 | (force-mode-line-update))) | |
194 | ||
195 | (defvar org-clock-mode-line-entry nil | |
196 | "Information for the modeline about the running clock.") | |
197 | ||
198 | (defun org-clock-in (&optional select) | |
199 | "Start the clock on the current item. | |
200 | If necessary, clock-out of the currently active clock. | |
201 | With prefix arg SELECT, offer a list of recently clocked ta sks to | |
202 | clock into. When SELECT is `C-u C-u', clock into the current task and mark | |
203 | is as the default task, a special task that will always be offered in | |
204 | the clocking selection, associated with the letter `d'." | |
205 | (interactive "P") | |
206 | (let ((interrupting (marker-buffer org-clock-marker)) | |
207 | ts selected-task) | |
208 | (when (equal select '(4)) | |
209 | (setq selected-task (org-clock-select-task "Clock-in on task: ")) | |
210 | (if selected-task | |
211 | (setq selected-task (copy-marker selected-task)) | |
212 | (error "Abort"))) | |
213 | ;; Are we interrupting the clocking of a differnt task? | |
214 | (if interrupting | |
215 | (progn | |
216 | (move-marker org-clock-interrupted-task | |
217 | (marker-position org-clock-marker) | |
218 | (marker-buffer org-clock-marker)) | |
219 | (org-clock-out t))) | |
220 | ||
221 | (when (equal select '(16)) | |
222 | (save-excursion | |
223 | (org-back-to-heading t) | |
224 | (move-marker org-clock-default-task (point)))) | |
225 | ||
226 | (save-excursion | |
227 | (org-back-to-heading t) | |
228 | (when (and selected-task (marker-buffer selected-task)) | |
229 | (set-buffer (marker-buffer selected-task)) | |
230 | (goto-char selected-task) | |
231 | (move-marker selected-task nil)) | |
232 | (or interrupting (move-marker org-clock-interrupted-task nil)) | |
233 | (org-clock-history-push) | |
234 | (when (and org-clock-in-switch-to-state | |
235 | (not (looking-at (concat outline-regexp "[ \t]*" | |
236 | org-clock-in-switch-to-state | |
237 | "\\>")))) | |
238 | (org-todo org-clock-in-switch-to-state)) | |
239 | (if (and org-clock-heading-function | |
240 | (functionp org-clock-heading-function)) | |
241 | (setq org-clock-heading (funcall org-clock-heading-function)) | |
242 | (if (looking-at org-complex-heading-regexp) | |
243 | (setq org-clock-heading (match-string 4)) | |
244 | (setq org-clock-heading "???"))) | |
245 | (setq org-clock-heading (propertize org-clock-heading 'face nil)) | |
246 | (org-clock-find-position) | |
247 | ||
248 | (insert "\n") (backward-char 1) | |
249 | (indent-relative) | |
250 | (insert org-clock-string " ") | |
251 | (setq org-clock-start-time (current-time)) | |
252 | (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) | |
253 | (move-marker org-clock-marker (point) (buffer-base-buffer)) | |
254 | (or global-mode-string (setq global-mode-string '(""))) | |
255 | (or (memq 'org-mode-line-string global-mode-string) | |
256 | (setq global-mode-string | |
257 | (append global-mode-string '(org-mode-line-string)))) | |
258 | (org-update-mode-line) | |
259 | (setq org-mode-line-timer (run-with-timer 60 60 'org-update-mode-line)) | |
260 | (message "Clock started at %s" ts)))) | |
261 | ||
262 | (defun org-clock-find-position () | |
263 | "Find the location where the next clock line should be inserted." | |
264 | (org-back-to-heading t) | |
265 | (catch 'exit | |
266 | (let ((beg (save-excursion | |
267 | (beginning-of-line 2) | |
268 | (or (bolp) (newline)) | |
269 | (point))) | |
270 | (end (progn (outline-next-heading) (point))) | |
271 | (re (concat "^[ \t]*" org-clock-string)) | |
272 | (cnt 0) | |
273 | first last) | |
274 | (goto-char beg) | |
275 | (when (eobp) (newline) (setq end (max (point) end))) | |
276 | (when (re-search-forward "^[ \t]*:CLOCK:" end t) | |
277 | ;; we seem to have a CLOCK drawer, so go there. | |
278 | (beginning-of-line 2) | |
279 | (throw 'exit t)) | |
280 | ;; Lets count the CLOCK lines | |
281 | (goto-char beg) | |
282 | (while (re-search-forward re end t) | |
283 | (setq first (or first (match-beginning 0)) | |
284 | last (match-beginning 0) | |
285 | cnt (1+ cnt))) | |
286 | (when (and (integerp org-clock-into-drawer) | |
287 | (>= (1+ cnt) org-clock-into-drawer)) | |
288 | ;; Wrap current entries into a new drawer | |
289 | (goto-char last) | |
290 | (beginning-of-line 2) | |
291 | (if (org-at-item-p) (org-end-of-item)) | |
292 | (insert ":END:\n") | |
293 | (beginning-of-line 0) | |
294 | (org-indent-line-function) | |
295 | (goto-char first) | |
296 | (insert ":CLOCK:\n") | |
297 | (beginning-of-line 0) | |
298 | (org-indent-line-function) | |
299 | (org-flag-drawer t) | |
300 | (beginning-of-line 2) | |
301 | (throw 'exit nil)) | |
302 | ||
303 | (goto-char beg) | |
304 | (while (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) | |
305 | (not (equal (match-string 1) org-clock-string))) | |
306 | ;; Planning info, skip to after it | |
307 | (beginning-of-line 2) | |
308 | (or (bolp) (newline))) | |
309 | (when (eq t org-clock-into-drawer) | |
310 | (insert ":CLOCK:\n:END:\n") | |
311 | (beginning-of-line -1) | |
312 | (org-indent-line-function) | |
313 | (org-flag-drawer t) | |
314 | (beginning-of-line 2) | |
315 | (org-indent-line-function))))) | |
316 | ||
317 | (defun org-clock-out (&optional fail-quietly) | |
318 | "Stop the currently running clock. | |
319 | If there is no running clock, throw an error, unless FAIL-QUIETLY is set." | |
320 | (interactive) | |
321 | (catch 'exit | |
322 | (if (not (marker-buffer org-clock-marker)) | |
323 | (if fail-quietly (throw 'exit t) (error "No active clock"))) | |
324 | (let (ts te s h m remove) | |
325 | (save-excursion | |
326 | (set-buffer (marker-buffer org-clock-marker)) | |
327 | (save-restriction | |
328 | (widen) | |
329 | (goto-char org-clock-marker) | |
330 | (beginning-of-line 1) | |
331 | (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) | |
332 | (equal (match-string 1) org-clock-string)) | |
333 | (setq ts (match-string 2)) | |
334 | (if fail-quietly (throw 'exit nil) (error "Clock start time is gone"))) | |
335 | (goto-char (match-end 0)) | |
336 | (delete-region (point) (point-at-eol)) | |
337 | (insert "--") | |
338 | (setq te (org-insert-time-stamp (current-time) 'with-hm 'inactive)) | |
339 | (setq s (- (time-to-seconds (apply 'encode-time (org-parse-time-string te))) | |
340 | (time-to-seconds (apply 'encode-time (org-parse-time-string ts)))) | |
341 | h (floor (/ s 3600)) | |
342 | s (- s (* 3600 h)) | |
343 | m (floor (/ s 60)) | |
344 | s (- s (* 60 s))) | |
345 | (insert " => " (format "%2d:%02d" h m)) | |
346 | (when (setq remove (and org-clock-out-remove-zero-time-clocks | |
347 | (= (+ h m) 0))) | |
348 | (beginning-of-line 1) | |
349 | (delete-region (point) (point-at-eol)) | |
350 | (and (looking-at "\n") (> (point-max) (1+ (point))) | |
351 | (delete-char 1))) | |
352 | (move-marker org-clock-marker nil) | |
353 | (when org-log-note-clock-out | |
354 | (org-add-log-setup 'clock-out)) | |
355 | (when org-mode-line-timer | |
356 | (cancel-timer org-mode-line-timer) | |
357 | (setq org-mode-line-timer nil)) | |
358 | (setq global-mode-string | |
359 | (delq 'org-mode-line-string global-mode-string)) | |
360 | (force-mode-line-update) | |
361 | (message "Clock stopped at %s after HH:MM = %d:%02d%s" te h m | |
362 | (if remove " => LINE REMOVED" ""))))))) | |
363 | ||
364 | (defun org-clock-cancel () | |
365 | "Cancel the running clock be removing the start timestamp." | |
366 | (interactive) | |
367 | (if (not (marker-buffer org-clock-marker)) | |
368 | (error "No active clock")) | |
369 | (save-excursion | |
370 | (set-buffer (marker-buffer org-clock-marker)) | |
371 | (goto-char org-clock-marker) | |
372 | (delete-region (1- (point-at-bol)) (point-at-eol))) | |
373 | (setq global-mode-string | |
374 | (delq 'org-mode-line-string global-mode-string)) | |
375 | (force-mode-line-update) | |
376 | (message "Clock canceled")) | |
377 | ||
378 | (defun org-clock-goto (&optional select) | |
379 | "Go to the currently clocked-in entry. | |
380 | With prefix arg SELECT, offer recently clocked tasks." | |
381 | (interactive "P") | |
382 | (let ((m (if select | |
383 | (org-clock-select-task "Select task to go to: ") | |
384 | org-clock-marker))) | |
385 | (if (not (marker-buffer m)) | |
386 | (if select | |
387 | (error "No task selected") | |
388 | (error "No active clock"))) | |
389 | (switch-to-buffer (marker-buffer m)) | |
390 | (goto-char m) | |
391 | (org-show-entry) | |
392 | (org-back-to-heading) | |
393 | (org-cycle-hide-drawers 'children) | |
394 | (recenter))) | |
395 | ||
396 | (defvar org-clock-file-total-minutes nil | |
397 | "Holds the file total time in minutes, after a call to `org-clock-sum'.") | |
398 | (make-variable-buffer-local 'org-clock-file-total-minutes) | |
399 | ||
400 | (defun org-clock-sum (&optional tstart tend) | |
401 | "Sum the times for each subtree. | |
402 | Puts the resulting times in minutes as a text property on each headline." | |
403 | (interactive) | |
404 | (let* ((bmp (buffer-modified-p)) | |
405 | (re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" | |
406 | org-clock-string | |
407 | "[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)")) | |
408 | (lmax 30) | |
409 | (ltimes (make-vector lmax 0)) | |
410 | (t1 0) | |
411 | (level 0) | |
412 | ts te dt | |
413 | time) | |
414 | (remove-text-properties (point-min) (point-max) '(:org-clock-minutes t)) | |
415 | (save-excursion | |
416 | (goto-char (point-max)) | |
417 | (while (re-search-backward re nil t) | |
418 | (cond | |
419 | ((match-end 2) | |
420 | ;; Two time stamps | |
421 | (setq ts (match-string 2) | |
422 | te (match-string 3) | |
423 | ts (time-to-seconds | |
424 | (apply 'encode-time (org-parse-time-string ts))) | |
425 | te (time-to-seconds | |
426 | (apply 'encode-time (org-parse-time-string te))) | |
427 | ts (if tstart (max ts tstart) ts) | |
428 | te (if tend (min te tend) te) | |
429 | dt (- te ts) | |
430 | t1 (if (> dt 0) (+ t1 (floor (/ dt 60))) t1))) | |
431 | ((match-end 4) | |
432 | ;; A naket time | |
433 | (setq t1 (+ t1 (string-to-number (match-string 5)) | |
434 | (* 60 (string-to-number (match-string 4)))))) | |
435 | (t ;; A headline | |
436 | (setq level (- (match-end 1) (match-beginning 1))) | |
437 | (when (or (> t1 0) (> (aref ltimes level) 0)) | |
438 | (loop for l from 0 to level do | |
439 | (aset ltimes l (+ (aref ltimes l) t1))) | |
440 | (setq t1 0 time (aref ltimes level)) | |
441 | (loop for l from level to (1- lmax) do | |
442 | (aset ltimes l 0)) | |
443 | (goto-char (match-beginning 0)) | |
444 | (put-text-property (point) (point-at-eol) :org-clock-minutes time))))) | |
445 | (setq org-clock-file-total-minutes (aref ltimes 0))) | |
446 | (set-buffer-modified-p bmp))) | |
447 | ||
448 | (defun org-clock-display (&optional total-only) | |
449 | "Show subtree times in the entire buffer. | |
450 | If TOTAL-ONLY is non-nil, only show the total time for the entire file | |
451 | in the echo area." | |
452 | (interactive) | |
453 | (org-remove-clock-overlays) | |
454 | (let (time h m p) | |
455 | (org-clock-sum) | |
456 | (unless total-only | |
457 | (save-excursion | |
458 | (goto-char (point-min)) | |
459 | (while (or (and (equal (setq p (point)) (point-min)) | |
460 | (get-text-property p :org-clock-minutes)) | |
461 | (setq p (next-single-property-change | |
462 | (point) :org-clock-minutes))) | |
463 | (goto-char p) | |
464 | (when (setq time (get-text-property p :org-clock-minutes)) | |
465 | (org-put-clock-overlay time (funcall outline-level)))) | |
466 | (setq h (/ org-clock-file-total-minutes 60) | |
467 | m (- org-clock-file-total-minutes (* 60 h))) | |
468 | ;; Arrange to remove the overlays upon next change. | |
469 | (when org-remove-highlights-with-change | |
470 | (org-add-hook 'before-change-functions 'org-remove-clock-overlays | |
471 | nil 'local)))) | |
472 | (message "Total file time: %d:%02d (%d hours and %d minutes)" h m h m))) | |
473 | ||
474 | (defvar org-clock-overlays nil) | |
475 | (make-variable-buffer-local 'org-clock-overlays) | |
476 | ||
477 | (defun org-put-clock-overlay (time &optional level) | |
478 | "Put an overlays on the current line, displaying TIME. | |
479 | If LEVEL is given, prefix time with a corresponding number of stars. | |
480 | This creates a new overlay and stores it in `org-clock-overlays', so that it | |
481 | will be easy to remove." | |
482 | (let* ((c 60) (h (floor (/ time 60))) (m (- time (* 60 h))) | |
483 | (l (if level (org-get-valid-level level 0) 0)) | |
484 | (off 0) | |
485 | ov tx) | |
486 | (org-move-to-column c) | |
487 | (unless (eolp) (skip-chars-backward "^ \t")) | |
488 | (skip-chars-backward " \t") | |
489 | (setq ov (org-make-overlay (1- (point)) (point-at-eol)) | |
490 | tx (concat (buffer-substring (1- (point)) (point)) | |
491 | (make-string (+ off (max 0 (- c (current-column)))) ?.) | |
492 | (org-add-props (format "%s %2d:%02d%s" | |
493 | (make-string l ?*) h m | |
494 | (make-string (- 16 l) ?\ )) | |
495 | '(face secondary-selection)) | |
496 | "")) | |
497 | (if (not (featurep 'xemacs)) | |
498 | (org-overlay-put ov 'display tx) | |
499 | (org-overlay-put ov 'invisible t) | |
500 | (org-overlay-put ov 'end-glyph (make-glyph tx))) | |
501 | (push ov org-clock-overlays))) | |
502 | ||
503 | (defun org-remove-clock-overlays (&optional beg end noremove) | |
504 | "Remove the occur highlights from the buffer. | |
505 | BEG and END are ignored. If NOREMOVE is nil, remove this function | |
506 | from the `before-change-functions' in the current buffer." | |
507 | (interactive) | |
508 | (unless org-inhibit-highlight-removal | |
509 | (mapc 'org-delete-overlay org-clock-overlays) | |
510 | (setq org-clock-overlays nil) | |
511 | (unless noremove | |
512 | (remove-hook 'before-change-functions | |
513 | 'org-remove-clock-overlays 'local)))) | |
514 | ||
515 | (defvar state) ;; dynamically scoped into this function | |
516 | (defun org-clock-out-if-current () | |
517 | "Clock out if the current entry contains the running clock. | |
518 | This is used to stop the clock after a TODO entry is marked DONE, | |
519 | and is only done if the variable `org-clock-out-when-done' is not nil." | |
520 | (when (and org-clock-out-when-done | |
521 | (member state org-done-keywords) | |
522 | (equal (marker-buffer org-clock-marker) (current-buffer)) | |
523 | (< (point) org-clock-marker) | |
524 | (> (save-excursion (outline-next-heading) (point)) | |
525 | org-clock-marker)) | |
526 | ;; Clock out, but don't accept a logging message for this. | |
527 | (let ((org-log-note-clock-out nil)) | |
528 | (org-clock-out)))) | |
529 | ||
530 | (add-hook 'org-after-todo-state-change-hook | |
531 | 'org-clock-out-if-current) | |
532 | ||
533 | ;;;###autoload | |
534 | (defun org-get-clocktable (&rest props) | |
535 | "Get a formatted clocktable with parameters according to PROPS. | |
536 | The table is created in a temporary buffer, fully formatted and | |
537 | fontified, and then returned." | |
538 | ;; Set the defaults | |
539 | (setq props (plist-put props :name "clocktable")) | |
540 | (unless (plist-member props :maxlevel) | |
541 | (setq props (plist-put props :maxlevel 2))) | |
542 | (unless (plist-member props :scope) | |
543 | (setq props (plist-put props :scope 'agenda))) | |
544 | (with-temp-buffer | |
545 | (org-mode) | |
546 | (org-create-dblock props) | |
547 | (org-update-dblock) | |
548 | (font-lock-fontify-buffer) | |
549 | (forward-line 2) | |
550 | (buffer-substring (point) (progn | |
551 | (re-search-forward "^#\\+END" nil t) | |
552 | (point-at-bol))))) | |
553 | ||
554 | (defun org-clock-report (&optional arg) | |
555 | "Create a table containing a report about clocked time. | |
556 | If the cursor is inside an existing clocktable block, then the table | |
557 | will be updated. If not, a new clocktable will be inserted. | |
558 | When called with a prefix argument, move to the first clock table in the | |
559 | buffer and update it." | |
560 | (interactive "P") | |
561 | (org-remove-clock-overlays) | |
562 | (when arg | |
563 | (org-find-dblock "clocktable") | |
564 | (org-show-entry)) | |
565 | (if (org-in-clocktable-p) | |
566 | (goto-char (org-in-clocktable-p)) | |
567 | (org-create-dblock (list :name "clocktable" | |
568 | :maxlevel 2 :scope 'file))) | |
569 | (org-update-dblock)) | |
570 | ||
571 | (defun org-in-clocktable-p () | |
572 | "Check if the cursor is in a clocktable." | |
573 | (let ((pos (point)) start) | |
574 | (save-excursion | |
575 | (end-of-line 1) | |
576 | (and (re-search-backward "^#\\+BEGIN:[ \t]+clocktable" nil t) | |
577 | (setq start (match-beginning 0)) | |
578 | (re-search-forward "^#\\+END:.*" nil t) | |
579 | (>= (match-end 0) pos) | |
580 | start)))) | |
581 | ||
582 | (defun org-clock-special-range (key &optional time as-strings) | |
583 | "Return two times bordering a special time range. | |
584 | Key is a symbol specifying the range and can be one of `today', `yesterday', | |
585 | `thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'. | |
586 | A week starts Monday 0:00 and ends Sunday 24:00. | |
587 | The range is determined relative to TIME. TIME defaults to the current time. | |
588 | The return value is a cons cell with two internal times like the ones | |
589 | returned by `current time' or `encode-time'. if AS-STRINGS is non-nil, | |
590 | the returned times will be formatted strings." | |
591 | (if (integerp key) (setq key (intern (number-to-string key)))) | |
592 | (let* ((tm (decode-time (or time (current-time)))) | |
593 | (s 0) (m (nth 1 tm)) (h (nth 2 tm)) | |
594 | (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm)) | |
595 | (dow (nth 6 tm)) | |
596 | (skey (symbol-name key)) | |
597 | (shift 0) | |
598 | s1 m1 h1 d1 month1 y1 diff ts te fm txt w date) | |
599 | (cond | |
600 | ((string-match "^[0-9]+$" skey) | |
601 | (setq y (string-to-number skey) m 1 d 1 key 'year)) | |
602 | ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)$" skey) | |
603 | (setq y (string-to-number (match-string 1 skey)) | |
604 | month (string-to-number (match-string 2 skey)) | |
605 | d 1 key 'month)) | |
606 | ((string-match "^\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)$" skey) | |
607 | (require 'cal-iso) | |
608 | (setq y (string-to-number (match-string 1 skey)) | |
609 | w (string-to-number (match-string 2 skey))) | |
610 | (setq date (calendar-gregorian-from-absolute | |
611 | (calendar-absolute-from-iso (list w 1 y)))) | |
612 | (setq d (nth 1 date) month (car date) y (nth 2 date) | |
613 | key 'week)) | |
614 | ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey) | |
615 | (setq y (string-to-number (match-string 1 skey)) | |
616 | month (string-to-number (match-string 2 skey)) | |
617 | d (string-to-number (match-string 3 skey)) | |
618 | key 'day)) | |
619 | ((string-match "\\([-+][0-9]+\\)$" skey) | |
620 | (setq shift (string-to-number (match-string 1 skey)) | |
621 | key (intern (substring skey 0 (match-beginning 1)))))) | |
622 | (unless shift | |
623 | (cond ((eq key 'yesterday) (setq key 'today shift -1)) | |
624 | ((eq key 'lastweek) (setq key 'week shift -1)) | |
625 | ((eq key 'lastmonth) (setq key 'month shift -1)) | |
626 | ((eq key 'lastyear) (setq key 'year shift -1)))) | |
627 | (cond | |
628 | ((memq key '(day today)) | |
629 | (setq d (+ d shift) h 0 m 0 h1 24 m1 0)) | |
630 | ((memq key '(week thisweek)) | |
631 | (setq diff (+ (* -7 shift) (if (= dow 0) 6 (1- dow))) | |
632 | m 0 h 0 d (- d diff) d1 (+ 7 d))) | |
633 | ((memq key '(month thismonth)) | |
634 | (setq d 1 h 0 m 0 d1 1 month (+ month shift) month1 (1+ month) h1 0 m1 0)) | |
635 | ((memq key '(year thisyear)) | |
636 | (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) | |
637 | (t (error "No such time block %s" key))) | |
638 | (setq ts (encode-time s m h d month y) | |
639 | te (encode-time (or s1 s) (or m1 m) (or h1 h) | |
640 | (or d1 d) (or month1 month) (or y1 y))) | |
641 | (setq fm (cdr org-time-stamp-formats)) | |
642 | (cond | |
643 | ((memq key '(day today)) | |
644 | (setq txt (format-time-string "%A, %B %d, %Y" ts))) | |
645 | ((memq key '(week thisweek)) | |
646 | (setq txt (format-time-string "week %G-W%V" ts))) | |
647 | ((memq key '(month thismonth)) | |
648 | (setq txt (format-time-string "%B %Y" ts))) | |
649 | ((memq key '(year thisyear)) | |
650 | (setq txt (format-time-string "the year %Y" ts)))) | |
651 | (if as-strings | |
652 | (list (format-time-string fm ts) (format-time-string fm te) txt) | |
653 | (list ts te txt)))) | |
654 | ||
655 | (defun org-clocktable-shift (dir n) | |
656 | "Try to shift the :block date of the clocktable at point. | |
657 | Point must be in the #+BEGIN: line of a clocktable, or this function | |
658 | will throw an error. | |
659 | DIR is a direction, a symbol `left', `right', `up', or `down'. | |
660 | Both `left' and `down' shift the block toward the past, `up' and `right' | |
661 | push it toward the future. | |
662 | N is the number of shift steps to take. The size of the step depends on | |
663 | the currently selected interval size." | |
664 | (setq n (prefix-numeric-value n)) | |
665 | (and (memq dir '(left down)) (setq n (- n))) | |
666 | (save-excursion | |
667 | (goto-char (point-at-bol)) | |
668 | (if (not (looking-at "#\\+BEGIN: clocktable\\>.*?:block[ \t]+\\(\\S-+\\)")) | |
669 | (error "Line needs a :block definition before this command works") | |
670 | (let* ((b (match-beginning 1)) (e (match-end 1)) | |
671 | (s (match-string 1)) | |
672 | block shift ins y mw d date wp m) | |
673 | (cond | |
674 | ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\\([-+][0-9]+\\)?$" s) | |
675 | (setq block (match-string 1 s) | |
676 | shift (if (match-end 2) | |
677 | (string-to-number (match-string 2 s)) | |
678 | 0)) | |
679 | (setq shift (+ shift n)) | |
680 | (setq ins (if (= shift 0) block (format "%s%+d" block shift)))) | |
681 | ((string-match "\\([0-9]+\\)\\(-\\([wW]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s) | |
682 | ;; 1 1 2 3 3 4 4 5 6 6 5 2 | |
683 | (setq y (string-to-number (match-string 1 s)) | |
684 | wp (and (match-end 3) (match-string 3 s)) | |
685 | mw (and (match-end 4) (string-to-number (match-string 4 s))) | |
686 | d (and (match-end 6) (string-to-number (match-string 6 s)))) | |
687 | (cond | |
688 | (d (setq ins (format-time-string | |
689 | "%Y-%m-%d" | |
690 | (encode-time 0 0 0 (+ d n) m y)))) | |
691 | ((and wp mw (> (length wp) 0)) | |
692 | (require 'cal-iso) | |
693 | (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y)))) | |
694 | (setq ins (format-time-string | |
695 | "%G-W%V" | |
696 | (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) | |
697 | (mw | |
698 | (setq ins (format-time-string | |
699 | "%Y-%m" | |
700 | (encode-time 0 0 0 1 (+ mw n) y)))) | |
701 | (y | |
702 | (setq ins (number-to-string (+ y n)))))) | |
703 | (t (error "Cannot shift clocktable block"))) | |
704 | (when ins | |
705 | (goto-char b) | |
706 | (insert ins) | |
707 | (delete-region (point) (+ (point) (- e b))) | |
708 | (beginning-of-line 1) | |
709 | (org-update-dblock) | |
710 | t))))) | |
711 | ||
712 | (defun org-dblock-write:clocktable (params) | |
713 | "Write the standard clocktable." | |
714 | (catch 'exit | |
715 | (let* ((hlchars '((1 . "*") (2 . "/"))) | |
716 | (ins (make-marker)) | |
717 | (total-time nil) | |
718 | (scope (plist-get params :scope)) | |
719 | (tostring (plist-get params :tostring)) | |
720 | (multifile (plist-get params :multifile)) | |
721 | (header (plist-get params :header)) | |
722 | (maxlevel (or (plist-get params :maxlevel) 3)) | |
723 | (step (plist-get params :step)) | |
724 | (emph (plist-get params :emphasize)) | |
725 | (ts (plist-get params :tstart)) | |
726 | (te (plist-get params :tend)) | |
727 | (block (plist-get params :block)) | |
728 | (link (plist-get params :link)) | |
729 | ipos time p level hlc hdl | |
730 | cc beg end pos tbl tbl1 range-text rm-file-column scope-is-list) | |
731 | (setq org-clock-file-total-minutes nil) | |
732 | (when step | |
733 | (unless (or block (and ts te)) | |
734 | (error "Clocktable `:step' can only be used with `:block' or `:tstart,:end'")) | |
735 | (org-clocktable-steps params) | |
736 | (throw 'exit nil)) | |
737 | (when block | |
738 | (setq cc (org-clock-special-range block nil t) | |
739 | ts (car cc) te (nth 1 cc) range-text (nth 2 cc))) | |
740 | (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts))) | |
741 | (when (integerp te) (setq te (calendar-gregorian-from-absolute te))) | |
742 | (when (and ts (listp ts)) | |
743 | (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts)))) | |
744 | (when (and te (listp te)) | |
745 | (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te)))) | |
746 | ;; Now the times are strings we can parse. | |
747 | (if ts (setq ts (time-to-seconds | |
748 | (apply 'encode-time (org-parse-time-string ts))))) | |
749 | (if te (setq te (time-to-seconds | |
750 | (apply 'encode-time (org-parse-time-string te))))) | |
751 | (move-marker ins (point)) | |
752 | (setq ipos (point)) | |
753 | ||
754 | ;; Get the right scope | |
755 | (setq pos (point)) | |
756 | (cond | |
757 | ((and scope (listp scope) (symbolp (car scope))) | |
758 | (setq scope (eval scope))) | |
759 | ((eq scope 'agenda) | |
760 | (setq scope (org-agenda-files t))) | |
761 | ((eq scope 'agenda-with-archives) | |
762 | (setq scope (org-agenda-files t)) | |
763 | (setq scope (org-add-archive-files scope))) | |
764 | ((eq scope 'file-with-archives) | |
765 | (setq scope (org-add-archive-files (list (buffer-file-name))) | |
766 | rm-file-column t))) | |
767 | (setq scope-is-list (and scope (listp scope))) | |
768 | (save-restriction | |
769 | (cond | |
770 | ((not scope)) | |
771 | ((eq scope 'file) (widen)) | |
772 | ((eq scope 'subtree) (org-narrow-to-subtree)) | |
773 | ((eq scope 'tree) | |
774 | (while (org-up-heading-safe)) | |
775 | (org-narrow-to-subtree)) | |
776 | ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$" | |
777 | (symbol-name scope))) | |
778 | (setq level (string-to-number (match-string 1 (symbol-name scope)))) | |
779 | (catch 'exit | |
780 | (while (org-up-heading-safe) | |
781 | (looking-at outline-regexp) | |
782 | (if (<= (org-reduced-level (funcall outline-level)) level) | |
783 | (throw 'exit nil)))) | |
784 | (org-narrow-to-subtree)) | |
785 | (scope-is-list | |
786 | (let* ((files scope) | |
787 | (scope 'agenda) | |
788 | (p1 (copy-sequence params)) | |
789 | file) | |
790 | (setq p1 (plist-put p1 :tostring t)) | |
791 | (setq p1 (plist-put p1 :multifile t)) | |
792 | (setq p1 (plist-put p1 :scope 'file)) | |
793 | (org-prepare-agenda-buffers files) | |
794 | (while (setq file (pop files)) | |
795 | (with-current-buffer (find-buffer-visiting file) | |
796 | (setq tbl1 (org-dblock-write:clocktable p1)) | |
797 | (when tbl1 | |
798 | (push (org-clocktable-add-file | |
799 | file | |
800 | (concat "| |*File time*|*" | |
801 | (org-minutes-to-hh:mm-string | |
802 | org-clock-file-total-minutes) | |
803 | "*|\n" | |
804 | tbl1)) tbl) | |
805 | (setq total-time (+ (or total-time 0) | |
806 | org-clock-file-total-minutes)))))))) | |
807 | (goto-char pos) | |
808 | ||
809 | (unless scope-is-list | |
810 | (org-clock-sum ts te) | |
811 | (goto-char (point-min)) | |
812 | (while (setq p (next-single-property-change (point) :org-clock-minutes)) | |
813 | (goto-char p) | |
814 | (when (setq time (get-text-property p :org-clock-minutes)) | |
815 | (save-excursion | |
816 | (beginning-of-line 1) | |
817 | (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@:]+:\\)?[ \t]*$")) | |
818 | (setq level (org-reduced-level | |
819 | (- (match-end 1) (match-beginning 1)))) | |
820 | (<= level maxlevel)) | |
821 | (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "") | |
822 | hdl (if (not link) | |
823 | (match-string 2) | |
824 | (org-make-link-string | |
825 | (format "file:%s::%s" | |
826 | (buffer-file-name) | |
827 | (save-match-data | |
828 | (org-make-org-heading-search-string | |
829 | (match-string 2)))) | |
830 | (match-string 2)))) | |
831 | (if (and (not multifile) (= level 1)) (push "|-" tbl)) | |
832 | (push (concat | |
833 | "| " (int-to-string level) "|" hlc hdl hlc " |" | |
834 | (make-string (1- level) ?|) | |
835 | hlc (org-minutes-to-hh:mm-string time) hlc | |
836 | " |") tbl)))))) | |
837 | (setq tbl (nreverse tbl)) | |
838 | (if tostring | |
839 | (if tbl (mapconcat 'identity tbl "\n") nil) | |
840 | (goto-char ins) | |
841 | (insert-before-markers | |
842 | (or header | |
843 | (concat | |
844 | "Clock summary at [" | |
845 | (substring | |
846 | (format-time-string (cdr org-time-stamp-formats)) | |
847 | 1 -1) | |
848 | "]" | |
849 | (if block (concat ", for " range-text ".") "") | |
850 | "\n\n")) | |
851 | (if scope-is-list "|File" "") | |
852 | "|L|Headline|Time|\n") | |
853 | (setq total-time (or total-time org-clock-file-total-minutes)) | |
854 | (insert-before-markers | |
855 | "|-\n|" | |
856 | (if scope-is-list "|" "") | |
857 | "|" | |
858 | "*Total time*| *" | |
859 | (org-minutes-to-hh:mm-string (or total-time 0)) | |
860 | "*|\n|-\n") | |
861 | (setq tbl (delq nil tbl)) | |
862 | (if (and (stringp (car tbl)) (> (length (car tbl)) 1) | |
863 | (equal (substring (car tbl) 0 2) "|-")) | |
864 | (pop tbl)) | |
865 | (insert-before-markers (mapconcat | |
866 | 'identity (delq nil tbl) | |
867 | (if scope-is-list "\n|-\n" "\n"))) | |
868 | (backward-delete-char 1) | |
869 | (goto-char ipos) | |
870 | (skip-chars-forward "^|") | |
871 | (org-table-align) | |
872 | (when rm-file-column | |
873 | (forward-char 1) | |
874 | (org-table-delete-column))))))) | |
875 | ||
876 | (defun org-clocktable-steps (params) | |
877 | (let* ((p1 (copy-sequence params)) | |
878 | (ts (plist-get p1 :tstart)) | |
879 | (te (plist-get p1 :tend)) | |
880 | (step0 (plist-get p1 :step)) | |
881 | (step (cdr (assoc step0 '((day . 86400) (week . 604800))))) | |
882 | (block (plist-get p1 :block)) | |
883 | cc range-text) | |
884 | (when block | |
885 | (setq cc (org-clock-special-range block nil t) | |
886 | ts (car cc) te (nth 1 cc) range-text (nth 2 cc))) | |
887 | (if ts (setq ts (time-to-seconds | |
888 | (apply 'encode-time (org-parse-time-string ts))))) | |
889 | (if te (setq te (time-to-seconds | |
890 | (apply 'encode-time (org-parse-time-string te))))) | |
891 | (setq p1 (plist-put p1 :header "")) | |
892 | (setq p1 (plist-put p1 :step nil)) | |
893 | (setq p1 (plist-put p1 :block nil)) | |
894 | (while (< ts te) | |
895 | (or (bolp) (insert "\n")) | |
896 | (setq p1 (plist-put p1 :tstart (format-time-string | |
897 | (car org-time-stamp-formats) | |
898 | (seconds-to-time ts)))) | |
899 | (setq p1 (plist-put p1 :tend (format-time-string | |
900 | (car org-time-stamp-formats) | |
901 | (seconds-to-time (setq ts (+ ts step)))))) | |
902 | (insert "\n" (if (eq step0 'day) "Daily report: " "Weekly report starting on: ") | |
903 | (plist-get p1 :tstart) "\n") | |
904 | (org-dblock-write:clocktable p1) | |
905 | (re-search-forward "#\\+END:") | |
906 | (end-of-line 0)))) | |
907 | ||
908 | ||
909 | (defun org-clocktable-add-file (file table) | |
910 | (if table | |
911 | (let ((lines (org-split-string table "\n")) | |
912 | (ff (file-name-nondirectory file))) | |
913 | (mapconcat 'identity | |
914 | (mapcar (lambda (x) | |
915 | (if (string-match org-table-dataline-regexp x) | |
916 | (concat "|" ff x) | |
917 | x)) | |
918 | lines) | |
919 | "\n")))) | |
920 | ||
921 | (provide 'org-clock) | |
922 | ||
923 | ;;; org-clock.el ends here | |
924 | ||
925 | ||
88ac7b50 | 926 | ;; arch-tag: 7b42c5d4-9b36-48be-97c0-66a869daed4c |