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