lisp/org-clock.el

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