;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
;; Homepage: http://orgmode.org
-;; Version: 6.35i
+;; Version: 7.4
;;
;; This file is part of GNU Emacs.
;;
;; This file contains the time clocking code for Org-mode
(require 'org)
+;;; Code:
+
(eval-when-compile
- (require 'cl)
- (require 'calendar))
+ (require 'cl))
-(declare-function calendar-absolute-from-iso "cal-iso" (&optional date))
+(declare-function calendar-absolute-from-iso "cal-iso" (&optional date))
+(declare-function notifications-notify "notifications" (&rest params))
(defvar org-time-stamp-formats)
(defgroup org-clock nil
(defcustom org-clock-in-switch-to-state nil
"Set task to a special todo state while clocking it.
The value should be the state to which the entry should be
-switched. If the value is a function, it must take one
+switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
(defcustom org-clock-out-switch-to-state nil
"Set task to a special todo state after clocking out.
The value should be the state to which the entry should be
-switched. If the value is a function, it must take one
+switched. If the value is a function, it must take one
parameter (the current TODO state of the item) and return the
state to switch it to."
:group 'org-clock
:type 'function)
(defcustom org-clock-string-limit 0
- "Maximum length of clock strings in the modeline. 0 means no limit."
+ "Maximum length of clock strings in the modeline. 0 means no limit."
:group 'org-clock
:type 'integer)
:type 'boolean)
(defcustom org-clock-persist nil
- "When non-nil, save the running clock when emacs is closed.
-The clock is resumed when emacs restarts.
+ "When non-nil, save the running clock when Emacs is closed.
+The clock is resumed when Emacs restarts.
When this is t, both the running clock, and the entire clock
history are saved. When this is the symbol `clock', only the
running clock is saved.
(string :tag "Program")
(function :tag "Function")))
-(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file)
- "Default properties for new clocktables."
+(defgroup org-clocktable nil
+ "Options concerning the clock table in Org-mode."
+ :tag "Org Clock Table"
+ :group 'org-clock)
+
+(defcustom org-clocktable-defaults
+ (list
+ :maxlevel 2
+ :scope 'file
+ :block nil
+ :tstart nil
+ :tend nil
+ :step nil
+ :stepskip0 nil
+ :fileskip0 nil
+ :tags nil
+ :emphasize nil
+ :link nil
+ :narrow '40!
+ :indent t
+ :formula nil
+ :timestamp nil
+ :level nil
+ :tcolumns nil
+ :formatter nil)
+ "Default properties for clock tables."
:group 'org-clock
:type 'plist)
+(defcustom org-clock-clocktable-formatter 'org-clocktable-write-default
+ "Function to turn clocking data into a table.
+For more information, see `org-clocktable-write-default'."
+ :group 'org-clocktable
+ :type 'function)
+
+(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file)
+ "Default properties for new clocktables.
+These will be inserted into the BEGIN line, to make it easy for users to
+play with them."
+ :group 'org-clocktable
+ :type 'plist)
+
(defcustom org-clock-idle-time nil
"When non-nil, resolve open clocks if the user is idle more than X minutes."
:group 'org-clock
:group 'org-clock
:type 'boolean)
+(defcustom org-clock-resolve-expert nil
+ "Non-nil means do not show the splash buffer with the clock resolver."
+ :group 'org-clock
+ :type 'boolean)
+
(defvar org-clock-in-prepare-hook nil
"Hook run when preparing the clock.
This hook is run before anything happens to the task that
"If non-nil, user cancelled a clock; this is when leftover time started.")
(defvar org-clock-effort ""
- "Effort estimate of the currently clocking task")
+ "Effort estimate of the currently clocking task.")
(defvar org-clock-total-time nil
"Holds total time, spent previously on currently clocked item.
(defun org-clock-history-push (&optional pos buffer)
"Push a marker to the clock history."
(setq org-clock-history-length (max 1 (min 35 org-clock-history-length)))
- (let ((m (move-marker (make-marker) (or pos (point)) buffer)) n l)
+ (let ((m (move-marker (make-marker)
+ (or pos (point)) (org-base-buffer
+ (or buffer (current-buffer)))))
+ n l)
(while (setq n (member m org-clock-history))
(move-marker (car n) nil))
(setq org-clock-history
org-clock-history))
(defun org-clocking-buffer ()
- "Returns clocking buffer if we are currently clocking a task or nil"
+ "Return the clocking buffer if we are currently clocking a task or nil."
(marker-buffer org-clock-marker))
(defun org-clocking-p ()
- "Returns t when clocking a task"
+ "Return t when clocking a task."
(not (equal (org-clocking-buffer) nil)))
(defun org-clock-select-task (&optional prompt)
;; A string. See if it is a delta
(setq sign (string-to-char value))
(if (member sign '(?- ?+))
- (setq current (org-hh:mm-string-to-minutes (substring current 1)))
+ (setq current (org-hh:mm-string-to-minutes current)
+ value (substring value 1))
(setq current 0))
(setq value (org-hh:mm-string-to-minutes value))
(if (equal ?- sign)
((stringp org-show-notification-handler)
(start-process "emacs-timer-notification" nil
org-show-notification-handler notification))
+ ((featurep 'notifications)
+ (require 'notifications)
+ (notifications-notify
+ :title "Org-mode message"
+ :body notification
+ ;; FIXME how to link to the Org icon?
+ ;; :app-icon "~/.emacs.d/icons/mail.png"
+ :urgency 'low))
((org-program-exists "notify-send")
(start-process "emacs-timer-notification" nil
"notify-send" notification))
(save-excursion
(goto-char (point-min))
(while (re-search-forward "CLOCK: \\(\\[.*?\\]\\)$" nil t)
- (push (cons (copy-marker (1- (match-end 1)) t)
+ (push (cons (copy-marker (match-end 1) t)
(org-time-string-to-time (match-string 1))) clocks))))
clocks))
(put 'org-with-clock 'lisp-indent-function 1)
-(defsubst org-clock-clock-in (clock &optional resume)
+(defsubst org-clock-clock-in (clock &optional resume start-time)
"Clock in to the clock located by CLOCK.
If necessary, clock-out of the currently active clock."
(org-with-clock-position clock
(let ((org-clock-in-resume (or resume org-clock-in-resume)))
- (org-clock-in))))
+ (org-clock-in nil start-time))))
(defsubst org-clock-clock-out (clock &optional fail-quietly at-time)
"Clock out of the clock located by CLOCK."
(defvar org-clock-resolving-clocks nil)
(defvar org-clock-resolving-clocks-due-to-idleness nil)
-(defun org-clock-resolve-clock (clock resolve-to &optional close-p
- restart-p fail-quietly)
+(defun org-clock-resolve-clock (clock resolve-to clock-out-time
+ &optional close-p restart-p fail-quietly)
"Resolve `CLOCK' given the time `RESOLVE-TO', and the present.
-`CLOCK' is a cons cell of the form (MARKER START-TIME).
-This routine can do one of many things:
-
- if `RESOLVE-TO' is nil
- if `CLOSE-P' is non-nil, give an error
- if this clock is the active clock, cancel it
- else delete the clock line (as if it never happened)
- if `RESTART-P' is non-nil, start a new clock
-
- else if `RESOLVE-TO' is the symbol `now'
- if `RESTART-P' is non-nil, give an error
- if `CLOSE-P' is non-nil, clock out the entry and
- if this clock is the active clock, stop it
- else if this clock is the active clock, do nothing
- else if there is no active clock, resume this clock
- else ask to cancel the active clock, and if so,
- resume this clock after cancelling it
-
- else if `RESOLVE-TO' is some date in the future
- give an error about `RESOLVE-TO' being invalid
-
- else if `RESOLVE-TO' is some date in the past
- if `RESTART-P' is non-nil, give an error
- if `CLOSE-P' is non-nil, enter a closing time and
- if this clock is the active clock, stop it
- else if this clock is the active clock, enter a
- closing time, stop the current clock, then
- start a new clock for the same item
- else just enter a closing time for this clock
- and then start a new clock for the same item"
+`CLOCK' is a cons cell of the form (MARKER START-TIME)."
(let ((org-clock-resolving-clocks t))
(cond
((null resolve-to)
(t
(if restart-p
(error "RESTART-P is not valid here"))
- (org-clock-clock-out clock fail-quietly resolve-to)
+ (org-clock-clock-out clock fail-quietly (or clock-out-time
+ resolve-to))
(unless org-clock-clocking-in
(if close-p
- (setq org-clock-leftover-time resolve-to)
- (org-clock-clock-in clock)))))))
+ (setq org-clock-leftover-time (and (null clock-out-time)
+ resolve-to))
+ (org-clock-clock-in clock nil (and clock-out-time
+ resolve-to))))))))
+
+(defun org-clock-jump-to-current-clock (&optional effective-clock)
+ (interactive)
+ (let ((clock (or effective-clock (cons org-clock-marker
+ org-clock-start-time))))
+ (unless (marker-buffer (car clock))
+ (error "No clock is currently running"))
+ (org-with-clock clock (org-clock-goto))
+ (with-current-buffer (marker-buffer (car clock))
+ (goto-char (car clock))
+ (if org-clock-into-drawer
+ (let ((logbook
+ (if (stringp org-clock-into-drawer)
+ (concat ":" org-clock-into-drawer ":")
+ ":LOGBOOK:")))
+ (ignore-errors
+ (outline-flag-region
+ (save-excursion
+ (outline-back-to-heading t)
+ (search-forward logbook)
+ (goto-char (match-beginning 0)))
+ (save-excursion
+ (outline-back-to-heading t)
+ (search-forward logbook)
+ (search-forward ":END:")
+ (goto-char (match-end 0)))
+ nil)))))))
(defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly)
"Resolve an open org-mode clock.
(save-window-excursion
(save-excursion
(unless org-clock-resolving-clocks-due-to-idleness
- (org-with-clock clock (org-clock-goto))
- (with-current-buffer (marker-buffer (car clock))
- (goto-char (car clock))
- (if org-clock-into-drawer
- (let ((logbook
- (if (stringp org-clock-into-drawer)
- (concat ":" org-clock-into-drawer ":")
- ":LOGBOOK:")))
- (ignore-errors
- (outline-flag-region
- (save-excursion
- (outline-back-to-heading t)
- (search-forward logbook)
- (goto-char (match-beginning 0)))
- (save-excursion
- (outline-back-to-heading t)
- (search-forward logbook)
- (search-forward ":END:")
- (goto-char (match-end 0)))
- nil))))))
+ (org-clock-jump-to-current-clock clock))
+ (unless org-clock-resolve-expert
+ (with-output-to-temp-buffer "*Org Clock*"
+ (princ "Select a Clock Resolution Command:
+
+i/q/C-g Ignore this question; the same as keeping all the idle time.
+
+k/K Keep X minutes of the idle time (default is all). If this
+ amount is less than the default, you will be clocked out
+ that many minutes after the time that idling began, and then
+ clocked back in at the present time.
+g/G Indicate that you \"got back\" X minutes ago. This is quite
+ different from 'k': it clocks you out from the beginning of
+ the idle period and clock you back in X minutes ago.
+s/S Subtract the idle time from the current clock. This is the
+ same as keeping 0 minutes.
+C Cancel the open timer altogether. It will be as though you
+ never clocked in.
+j/J Jump to the current clock, to make manual adjustments.
+
+For all these options, using uppercase makes your final state
+to be CLOCKED OUT.")))
+ (org-fit-window-to-buffer (get-buffer-window "*Org Clock*"))
(let (char-pressed)
- (if (featurep 'xemacs)
- (progn
- (message (concat (funcall prompt-fn clock)
- " [(kK)eep (sS)ubtract (C)ancel]? "))
- (setq char-pressed (read-char-exclusive)))
+ (when (featurep 'xemacs)
+ (message (concat (funcall prompt-fn clock)
+ " [jkKgGsScCiq]? "))
+ (setq char-pressed (read-char-exclusive)))
(while (or (null char-pressed)
- (and (not (memq char-pressed '(?k ?K ?s ?S ?C ?i)))
+ (and (not (memq char-pressed
+ '(?k ?K ?g ?G ?s ?S ?C
+ ?j ?J ?i ?q)))
(or (ding) t)))
(setq char-pressed
(read-char (concat (funcall prompt-fn clock)
- " [(kK)p (sS)ub (C)ncl (i)gn]? ")
+ " [jkKgGSscCiq]? ")
nil 45)))
- (and (not (eq char-pressed ?i)) char-pressed))))))
- (default (floor (/ (org-float-time
- (time-subtract (current-time) last-valid)) 60)))
- (keep (and (memq ch '(?k ?K))
- (read-number "Keep how many minutes? " default)))
+ (and (not (memq char-pressed '(?i ?q))) char-pressed)))))
+ (default
+ (floor (/ (org-float-time
+ (time-subtract (current-time) last-valid)) 60)))
+ (keep
+ (and (memq ch '(?k ?K))
+ (read-number "Keep how many minutes? " default)))
+ (gotback
+ (and (memq ch '(?g ?G))
+ (read-number "Got back how many minutes ago? " default)))
(subtractp (memq ch '(?s ?S)))
(barely-started-p (< (- (org-float-time last-valid)
(org-float-time (cdr clock))) 45))
(start-over (and subtractp barely-started-p)))
- (if (or (null ch)
- (not (memq ch '(?k ?K ?s ?S ?C))))
- (message "")
+ (cond
+ ((memq ch '(?j ?J))
+ (if (eq ch ?J)
+ (org-clock-resolve-clock clock 'now nil t nil fail-quietly))
+ (org-clock-jump-to-current-clock clock))
+ ((or (null ch)
+ (not (memq ch '(?k ?K ?g ?G ?s ?S ?C))))
+ (message ""))
+ (t
(org-clock-resolve-clock
clock (cond
((or (eq ch ?C)
;; time...
start-over)
nil)
- (subtractp
+ ((or subtractp
+ (and gotback (= gotback 0)))
last-valid)
- ((= keep default)
+ ((or (and keep (= keep default))
+ (and gotback (= gotback default)))
'now)
+ (keep
+ (time-add last-valid (seconds-to-time (* 60 keep))))
+ (gotback
+ (time-subtract (current-time)
+ (seconds-to-time (* 60 gotback))))
(t
- (time-add last-valid (seconds-to-time (* 60 keep)))))
- (memq ch '(?K ?S))
+ (error "Unexpected, please report this as a bug")))
+ (and gotback last-valid)
+ (memq ch '(?K ?G ?S))
(and start-over
- (not (memq ch '(?K ?S ?C))))
- fail-quietly))))
+ (not (memq ch '(?K ?G ?S ?C))))
+ fail-quietly)))))
-(defun org-resolve-clocks (&optional also-non-dangling-p prompt-fn last-valid)
+(defun org-resolve-clocks (&optional only-dangling-p prompt-fn last-valid)
"Resolve all currently open org-mode clocks.
-If `also-non-dangling-p' is non-nil, also ask to resolve
-non-dangling (i.e., currently open and valid) clocks."
+If `only-dangling-p' is non-nil, only ask to resolve dangling
+\(i.e., not currently open and valid) clocks."
(interactive "P")
(unless org-clock-resolving-clocks
(let ((org-clock-resolving-clocks t))
(dolist (clock clocks)
(let ((dangling (or (not (org-clock-is-active))
(/= (car clock) org-clock-marker))))
- (unless (and (not dangling) (not also-non-dangling-p))
+ (if (or (not only-dangling-p) dangling)
(org-clock-resolve
clock
(or prompt-fn
0)))
(defun org-mac-idle-seconds ()
- "Return the current Mac idle time in seconds"
+ "Return the current Mac idle time in seconds."
(string-to-number (shell-command-to-string "ioreg -c IOHIDSystem | perl -ane 'if (/Idle/) {$idle=(pop @F)/1000000000; print $idle; last}'")))
(defun org-x11-idle-seconds ()
- "Return the current X11 idle time in seconds"
+ "Return the current X11 idle time in seconds."
(/ (string-to-number (shell-command-to-string "x11idle")) 1000))
(defun org-user-idle-seconds ()
60.0))))
org-clock-user-idle-start)))))
-(defun org-clock-in (&optional select)
+(defun org-clock-in (&optional select start-time)
"Start the clock on the current item.
If necessary, clock-out of the currently active clock.
-With prefix arg SELECT, offer a list of recently clocked tasks to
-clock into. When SELECT is `C-u C-u', clock into the current task and mark
+With a prefix argument SELECT (\\[universal-argument]), offer a list of \
+recently clocked tasks to
+clock into. When SELECT is \\[universal-argument] \\[universal-argument], \
+clock into the current task and mark
is as the default task, a special task that will always be offered in
the clocking selection, associated with the letter `d'."
(interactive "P")
;; We are interrupting the clocking of a different task.
;; Save a marker to this task, so that we can go back.
;; First check if we are trying to clock into the same task!
- (if (save-excursion
+ (when (save-excursion
(unless selected-task
(org-back-to-heading t))
(and (equal (marker-buffer org-clock-hd-marker)
(if selected-task
(marker-position selected-task)
(point)))))
- (message "Clock continues in \"%s\"" org-clock-heading)
- (progn
- (move-marker org-clock-interrupted-task
- (marker-position org-clock-marker)
- (org-clocking-buffer))
- (org-clock-out t))))
+ (message "Clock continues in \"%s\"" org-clock-heading)
+ (throw 'abort nil))
+ (move-marker org-clock-interrupted-task
+ (marker-position org-clock-marker)
+ (marker-buffer org-clock-marker))
+ (let ((org-clock-clocking-in t))
+ (org-clock-out t)))
(when (equal select '(16))
;; Mark as default clocking task
(/ (- (org-float-time (current-time))
(org-float-time leftover)) 60)))
leftover)
+ start-time
(current-time)))
(setq ts (org-insert-time-stamp org-clock-start-time
'with-hm 'inactive))))
"Task currently clocked in.")
(defun org-clock-set-current ()
"Set `org-clock-current-task' to the task currently clocked in."
- (setq org-clock-current-task (org-get-heading)))
+ (setq org-clock-current-task (nth 4 (org-heading-components))))
+
(defun org-clock-delete-current ()
"Reset `org-clock-current-task' to nil."
(setq org-clock-current-task nil))
If there is no running clock, throw an error, unless FAIL-QUIETLY is set."
(interactive)
(catch 'exit
- (if (not (org-clocking-p))
- (if fail-quietly (throw 'exit t) (error "No active clock")))
+ (when (not (org-clocking-p))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
+ (if fail-quietly (throw 'exit t) (error "No active clock")))
(let (ts te s h m remove)
- (save-excursion
- (set-buffer (org-clocking-buffer))
+ (save-excursion ; Do not replace this with `with-current-buffer'.
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(save-restriction
(widen)
(goto-char org-clock-marker)
(org-clock-delete-current))))))
(defun org-clock-cancel ()
- "Cancel the running clock be removing the start timestamp."
+ "Cancel the running clock by removing the start timestamp."
(interactive)
- (if (not (org-clocking-p))
- (error "No active clock"))
- (save-excursion
- (set-buffer (org-clocking-buffer))
+ (when (not (org-clocking-p))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
+ (error "No active clock"))
+ (save-excursion ; Do not replace this with `with-current-buffer'.
+ (with-no-warnings (set-buffer (org-clocking-buffer)))
(goto-char org-clock-marker)
(delete-region (1- (point-at-bol)) (point-at-eol))
;; Just in case, remove any empty LOGBOOK left over
"Holds the file total time in minutes, after a call to `org-clock-sum'.")
(make-variable-buffer-local 'org-clock-file-total-minutes)
-(defun org-clock-sum (&optional tstart tend)
+(defun org-clock-sum (&optional tstart tend headline-filter)
"Sum the times for each subtree.
Puts the resulting times in minutes as a text property on each headline.
-TSTART and TEND can mark a time range to be considered."
+TSTART and TEND can mark a time range to be considered. HEADLINE-FILTER is a
+zero-arg function that, if specified, is called for each headline in the time
+range with point at the headline. Headlines for which HEADLINE-FILTER returns
+nil are excluded from the clock summation."
(interactive)
(let* ((bmp (buffer-modified-p))
(re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
(if (stringp tend) (setq tend (org-time-string-to-seconds tend)))
(if (consp tstart) (setq tstart (org-float-time tstart)))
(if (consp tend) (setq tend (org-float-time tend)))
- (remove-text-properties (point-min) (point-max) '(:org-clock-minutes t))
+ (remove-text-properties (point-min) (point-max)
+ '(:org-clock-minutes t
+ :org-clock-force-headline-inclusion t))
(save-excursion
(goto-char (point-max))
(while (re-search-backward re nil t)
;; Add the currently clocking item time to the total
(when (and org-clock-report-include-clocking-task
(equal (org-clocking-buffer) (current-buffer))
- (equal (marker-position org-clock-hd-marker) (point)))
- (let ((time (floor (- (org-float-time)
- (org-float-time org-clock-start-time)) 60)))
- (setq t1 (+ t1 time))))
- (setq level (- (match-end 1) (match-beginning 1)))
- (when (or (> t1 0) (> (aref ltimes level) 0))
- (loop for l from 0 to level do
- (aset ltimes l (+ (aref ltimes l) t1)))
- (setq t1 0 time (aref ltimes level))
- (loop for l from level to (1- lmax) do
- (aset ltimes l 0))
- (goto-char (match-beginning 0))
- (put-text-property (point) (point-at-eol) :org-clock-minutes time)))))
+ (equal (marker-position org-clock-hd-marker) (point))
+ tstart
+ tend
+ (>= (org-float-time org-clock-start-time) tstart)
+ (<= (org-float-time org-clock-start-time) tend))
+ (let ((time (floor (- (org-float-time)
+ (org-float-time org-clock-start-time)) 60)))
+ (setq t1 (+ t1 time))))
+ (let* ((headline-forced
+ (get-text-property (point)
+ :org-clock-force-headline-inclusion))
+ (headline-included
+ (or (null headline-filter)
+ (save-excursion
+ (save-match-data (funcall headline-filter))))))
+ (setq level (- (match-end 1) (match-beginning 1)))
+ (when (or (> t1 0) (> (aref ltimes level) 0))
+ (when (or headline-included headline-forced)
+ (if headline-included
+ (loop for l from 0 to level do
+ (aset ltimes l (+ (aref ltimes l) t1))))
+ (setq time (aref ltimes level))
+ (goto-char (match-beginning 0))
+ (put-text-property (point) (point-at-eol) :org-clock-minutes time)
+ (if headline-filter
+ (save-excursion
+ (save-match-data
+ (while
+ (> (funcall outline-level) 1)
+ (outline-up-heading 1 t)
+ (put-text-property
+ (point) (point-at-eol)
+ :org-clock-force-headline-inclusion t))))))
+ (setq t1 0)
+ (loop for l from level to (1- lmax) do
+ (aset ltimes l 0)))))))
(setq org-clock-file-total-minutes (aref ltimes 0)))
(set-buffer-modified-p bmp)))
(defun org-clock-sum-current-item (&optional tstart)
- "Returns time, clocked on current item in total"
+ "Return time, clocked on current item in total."
(save-excursion
(save-restriction
(org-narrow-to-subtree)
(org-move-to-column c)
(unless (eolp) (skip-chars-backward "^ \t"))
(skip-chars-backward " \t")
- (setq ov (org-make-overlay (1- (point)) (point-at-eol))
+ (setq ov (make-overlay (1- (point)) (point-at-eol))
tx (concat (buffer-substring (1- (point)) (point))
(make-string (+ off (max 0 (- c (current-column)))) ?.)
(org-add-props (if org-time-clocksum-use-fractional
(list 'face 'org-clock-overlay))
""))
(if (not (featurep 'xemacs))
- (org-overlay-put ov 'display tx)
- (org-overlay-put ov 'invisible t)
- (org-overlay-put ov 'end-glyph (make-glyph tx)))
+ (overlay-put ov 'display tx)
+ (overlay-put ov 'invisible t)
+ (overlay-put ov 'end-glyph (make-glyph tx)))
(push ov org-clock-overlays)))
(defun org-clock-remove-overlays (&optional beg end noremove)
from the `before-change-functions' in the current buffer."
(interactive)
(unless org-inhibit-highlight-removal
- (mapc 'org-delete-overlay org-clock-overlays)
+ (mapc 'delete-overlay org-clock-overlays)
(setq org-clock-overlays nil)
(unless noremove
(remove-hook 'before-change-functions
(font-lock-fontify-buffer)
(forward-line 2)
(buffer-substring (point) (progn
- (re-search-forward "^#\\+END" nil t)
+ (re-search-forward "^[ \t]*#\\+END" nil t)
(point-at-bol)))))
(defun org-clock-report (&optional arg)
(let ((pos (point)) start)
(save-excursion
(end-of-line 1)
- (and (re-search-backward "^#\\+BEGIN:[ \t]+clocktable" nil t)
+ (and (re-search-backward "^[ \t]*#\\+BEGIN:[ \t]+clocktable" nil t)
(setq start (match-beginning 0))
- (re-search-forward "^#\\+END:.*" nil t)
+ (re-search-forward "^[ \t]*#\\+END:.*" nil t)
(>= (match-end 0) pos)
start))))
+(defun org-day-of-week (day month year)
+ "Returns the day of the week as an integer."
+ (nth 6
+ (decode-time
+ (date-to-time
+ (format "%d-%02d-%02dT00:00:00" year month day)))))
+
+(defun org-quarter-to-date (quarter year)
+ "Get the date (week day year) of the first day of a given quarter."
+ (let (startday)
+ (cond
+ ((= quarter 1)
+ (setq startday (org-day-of-week 1 1 year))
+ (cond
+ ((= startday 0)
+ (list 52 7 (- year 1)))
+ ((= startday 6)
+ (list 52 6 (- year 1)))
+ ((<= startday 4)
+ (list 1 startday year))
+ ((> startday 4)
+ (list 53 startday (- year 1)))
+ )
+ )
+ ((= quarter 2)
+ (setq startday (org-day-of-week 1 4 year))
+ (cond
+ ((= startday 0)
+ (list 13 startday year))
+ ((< startday 4)
+ (list 14 startday year))
+ ((>= startday 4)
+ (list 13 startday year))
+ )
+ )
+ ((= quarter 3)
+ (setq startday (org-day-of-week 1 7 year))
+ (cond
+ ((= startday 0)
+ (list 26 startday year))
+ ((< startday 4)
+ (list 27 startday year))
+ ((>= startday 4)
+ (list 26 startday year))
+ )
+ )
+ ((= quarter 4)
+ (setq startday (org-day-of-week 1 10 year))
+ (cond
+ ((= startday 0)
+ (list 39 startday year))
+ ((<= startday 4)
+ (list 40 startday year))
+ ((> startday 4)
+ (list 39 startday year)))))))
+
(defun org-clock-special-range (key &optional time as-strings)
"Return two times bordering a special time range.
Key is a symbol specifying the range and can be one of `today', `yesterday',
(dow (nth 6 tm))
(skey (symbol-name key))
(shift 0)
- s1 m1 h1 d1 month1 y1 diff ts te fm txt w date)
+ (q (cond ((>= (nth 4 tm) 10) 4)
+ ((>= (nth 4 tm) 7) 3)
+ ((>= (nth 4 tm) 4) 2)
+ ((>= (nth 4 tm) 1) 1)))
+ s1 m1 h1 d1 month1 y1 diff ts te fm txt w date
+ interval tmp shiftedy shiftedm shiftedq)
(cond
((string-match "^[0-9]+$" skey)
(setq y (string-to-number skey) m 1 d 1 key 'year))
(setq d (nth 1 date) month (car date) y (nth 2 date)
dow 1
key 'week))
+ ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey)
+ (require 'cal-iso)
+ (setq y (string-to-number (match-string 1 skey)))
+ (setq q (string-to-number (match-string 2 skey)))
+ (setq date (calendar-gregorian-from-absolute
+ (calendar-absolute-from-iso (org-quarter-to-date q y))))
+ (setq d (nth 1 date) month (car date) y (nth 2 date)
+ dow 1
+ key 'quarter))
((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey)
(setq y (string-to-number (match-string 1 skey))
month (string-to-number (match-string 2 skey))
key 'day))
((string-match "\\([-+][0-9]+\\)$" skey)
(setq shift (string-to-number (match-string 1 skey))
- key (intern (substring skey 0 (match-beginning 1))))))
+ key (intern (substring skey 0 (match-beginning 1))))
+ (if(and (memq key '(quarter thisq)) (> shift 0))
+ (error "Looking forward with quarters isn't implemented.")
+ ())))
+
(when (= shift 0)
- (cond ((eq key 'yesterday) (setq key 'today shift -1))
- ((eq key 'lastweek) (setq key 'week shift -1))
- ((eq key 'lastmonth) (setq key 'month shift -1))
- ((eq key 'lastyear) (setq key 'year shift -1))))
+ (cond ((eq key 'yesterday) (setq key 'today shift -1))
+ ((eq key 'lastweek) (setq key 'week shift -1))
+ ((eq key 'lastmonth) (setq key 'month shift -1))
+ ((eq key 'lastyear) (setq key 'year shift -1))
+ ((eq key 'lastq) (setq key 'quarter shift -1))))
(cond
((memq key '(day today))
(setq d (+ d shift) h 0 m 0 h1 24 m1 0))
m 0 h 0 d (- d diff) d1 (+ 7 d)))
((memq key '(month thismonth))
(setq d 1 h 0 m 0 d1 1 month (+ month shift) month1 (1+ month) h1 0 m1 0))
+ ((memq key '(quarter thisq))
+ ; compute if this shift remains in this year
+ ; if not, compute how many years and quarters we have to shift (via floor*)
+ ; and compute the shifted years, months and quarters
+ (cond
+ ((< (+ (- q 1) shift) 0) ; shift not in this year
+ (setq interval (* -1 (+ (- q 1) shift)))
+ ; set tmp to ((years to shift) (quarters to shift))
+ (setq tmp (org-floor* interval 4))
+ ; due to the use of floor, 0 quarters actually means 4
+ (if (= 0 (nth 1 tmp))
+ (setq shiftedy (- y (nth 0 tmp))
+ shiftedm 1
+ shiftedq 1)
+ (setq shiftedy (- y (+ 1 (nth 0 tmp)))
+ shiftedm (- 13 (* 3 (nth 1 tmp)))
+ shiftedq (- 5 (nth 1 tmp))))
+ (setq d 1 h 0 m 0 d1 1 month shiftedm month1 (+ 3 shiftedm) h1 0 m1 0 y shiftedy))
+ ((> (+ q shift) 0) ; shift is whitin this year
+ (setq shiftedq (+ q shift))
+ (setq shiftedy y)
+ (setq d 1 h 0 m 0 d1 1 month (+ 1 (* 3 (- (+ q shift) 1))) month1 (+ 4 (* 3 (- (+ q shift) 1))) h1 0 m1 0))))
((memq key '(year thisyear))
(setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y)))
(t (error "No such time block %s" key)))
((memq key '(month thismonth))
(setq txt (format-time-string "%B %Y" ts)))
((memq key '(year thisyear))
- (setq txt (format-time-string "the year %Y" ts))))
+ (setq txt (format-time-string "the year %Y" ts)))
+ ((memq key '(quarter thisq))
+ (setq txt (concatenate 'string (org-count-quarter shiftedq) " quarter of " (number-to-string shiftedy))))
+ )
(if as-strings
(list (format-time-string fm ts) (format-time-string fm te) txt)
(list ts te txt))))
+(defun org-count-quarter (n)
+ (cond
+ ((= n 1) "1st")
+ ((= n 2) "2nd")
+ ((= n 3) "3rd")
+ ((= n 4) "4th")))
+
(defun org-clocktable-shift (dir n)
"Try to shift the :block date of the clocktable at point.
Point must be in the #+BEGIN: line of a clocktable, or this function
(and (memq dir '(left down)) (setq n (- n)))
(save-excursion
(goto-char (point-at-bol))
- (if (not (looking-at "#\\+BEGIN: clocktable\\>.*?:block[ \t]+\\(\\S-+\\)"))
+ (if (not (looking-at "^[ \t]*#\\+BEGIN:[ \t]+clocktable\\>.*?:block[ \t]+\\(\\S-+\\)"))
(error "Line needs a :block definition before this command works")
(let* ((b (match-beginning 1)) (e (match-end 1))
(s (match-string 1))
((equal s "yesterday") (setq s "today-1"))
((equal s "lastweek") (setq s "thisweek-1"))
((equal s "lastmonth") (setq s "thismonth-1"))
- ((equal s "lastyear") (setq s "thisyear-1")))
- (cond
- ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\)\\([-+][0-9]+\\)?$" s)
- (setq block (match-string 1 s)
- shift (if (match-end 2)
- (string-to-number (match-string 2 s))
- 0))
- (setq shift (+ shift n))
- (setq ins (if (= shift 0) block (format "%s%+d" block shift))))
- ((string-match "\\([0-9]+\\)\\(-\\([wW]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s)
- ;; 1 1 2 3 3 4 4 5 6 6 5 2
- (setq y (string-to-number (match-string 1 s))
- wp (and (match-end 3) (match-string 3 s))
- mw (and (match-end 4) (string-to-number (match-string 4 s)))
- d (and (match-end 6) (string-to-number (match-string 6 s))))
- (cond
- (d (setq ins (format-time-string
- "%Y-%m-%d"
- (encode-time 0 0 0 (+ d n) m y))))
- ((and wp mw (> (length wp) 0))
- (require 'cal-iso)
- (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y))))
- (setq ins (format-time-string
- "%G-W%V"
- (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
- (mw
- (setq ins (format-time-string
- "%Y-%m"
- (encode-time 0 0 0 1 (+ mw n) y))))
- (y
- (setq ins (number-to-string (+ y n))))))
- (t (error "Cannot shift clocktable block")))
- (when ins
- (goto-char b)
- (insert ins)
- (delete-region (point) (+ (point) (- e b)))
- (beginning-of-line 1)
- (org-update-dblock)
- t)))))
+ ((equal s "lastyear") (setq s "thisyear-1"))
+ ((equal s "lastq") (setq s "thisq-1")))
+
+ (cond
+ ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\|thisq\\)\\([-+][0-9]+\\)?$" s)
+ (setq block (match-string 1 s)
+ shift (if (match-end 2)
+ (string-to-number (match-string 2 s))
+ 0))
+ (setq shift (+ shift n))
+ (setq ins (if (= shift 0) block (format "%s%+d" block shift))))
+ ((string-match "\\([0-9]+\\)\\(-\\([wWqQ]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s)
+ ;; 1 1 2 3 3 4 4 5 6 6 5 2
+ (setq y (string-to-number (match-string 1 s))
+ wp (and (match-end 3) (match-string 3 s))
+ mw (and (match-end 4) (string-to-number (match-string 4 s)))
+ d (and (match-end 6) (string-to-number (match-string 6 s))))
+ (cond
+ (d (setq ins (format-time-string
+ "%Y-%m-%d"
+ (encode-time 0 0 0 (+ d n) m y))))
+ ((and wp (string-match "w\\|W" wp) mw (> (length wp) 0))
+ (require 'cal-iso)
+ (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y))))
+ (setq ins (format-time-string
+ "%G-W%V"
+ (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
+ ((and wp (string-match "q\\|Q" wp) mw (> (length wp) 0))
+ (require 'cal-iso)
+ ; if the 4th + 1 quarter is requested we flip to the 1st quarter of the next year
+ (if (> (+ mw n) 4)
+ (setq mw 0
+ y (+ 1 y))
+ ())
+ ; if the 1st - 1 quarter is requested we flip to the 4th quarter of the previous year
+ (if (= (+ mw n) 0)
+ (setq mw 5
+ y (- y 1))
+ ())
+ (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (org-quarter-to-date (+ mw n) y))))
+ (setq ins (format-time-string
+ (concatenate 'string (number-to-string y) "-Q" (number-to-string (+ mw n)))
+ (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date)))))
+ (mw
+ (setq ins (format-time-string
+ "%Y-%m"
+ (encode-time 0 0 0 1 (+ mw n) y))))
+ (y
+ (setq ins (number-to-string (+ y n))))))
+ (t (error "Cannot shift clocktable block")))
+ (when ins
+ (goto-char b)
+ (insert ins)
+ (delete-region (point) (+ (point) (- e b)))
+ (beginning-of-line 1)
+ (org-update-dblock)
+ t)))))
(defun org-dblock-write:clocktable (params)
"Write the standard clocktable."
+ (setq params (org-combine-plists org-clocktable-defaults params))
(catch 'exit
- (let* ((hlchars '((1 . "*") (2 . "/")))
- (ins (make-marker))
- (total-time nil)
- (scope (plist-get params :scope))
- (tostring (plist-get params :tostring))
- (multifile (plist-get params :multifile))
- (header (plist-get params :header))
- (maxlevel (or (plist-get params :maxlevel) 3))
- (step (plist-get params :step))
- (emph (plist-get params :emphasize))
- (timestamp (plist-get params :timestamp))
+ (let* ((scope (plist-get params :scope))
+ (block (plist-get params :block))
(ts (plist-get params :tstart))
(te (plist-get params :tend))
- (block (plist-get params :block))
(link (plist-get params :link))
- ipos time p level hlc hdl tsp props content recalc formula pcol
- cc beg end pos tbl tbl1 range-text rm-file-column scope-is-list st)
- (setq org-clock-file-total-minutes nil)
+ (maxlevel (or (plist-get params :maxlevel) 3))
+ (step (plist-get params :step))
+ (timestamp (plist-get params :timestamp))
+ (formatter (or (plist-get params :formatter)
+ org-clock-clocktable-formatter
+ 'org-clocktable-write-default))
+ cc range-text ipos pos one-file-with-archives
+ scope-is-list tbls level)
+
+ ;; Check if we need to do steps
+ (when block
+ ;; Get the range text for the header
+ (setq cc (org-clock-special-range block nil t)
+ ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
(when step
+ ;; Write many tables, in steps
(unless (or block (and ts te))
(error "Clocktable `:step' can only be used with `:block' or `:tstart,:end'"))
(org-clocktable-steps params)
(throw 'exit nil))
- (when block
- (setq cc (org-clock-special-range block nil t)
- ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
- (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
- (when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
- (when (and ts (listp ts))
- (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts))))
- (when (and te (listp te))
- (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te))))
- ;; Now the times are strings we can parse.
- (if ts (setq ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts)))))
- (if te (setq te (org-float-time
- (apply 'encode-time (org-parse-time-string te)))))
- (move-marker ins (point))
- (setq ipos (point))
+
+ (setq ipos (point)) ; remember the insertion position
;; Get the right scope
(setq pos (point))
(setq scope (org-add-archive-files scope)))
((eq scope 'file-with-archives)
(setq scope (org-add-archive-files (list (buffer-file-name)))
- rm-file-column t)))
+ one-file-with-archives t)))
(setq scope-is-list (and scope (listp scope)))
- (save-restriction
- (cond
- ((not scope))
- ((eq scope 'file) (widen))
- ((eq scope 'subtree) (org-narrow-to-subtree))
- ((eq scope 'tree)
- (while (org-up-heading-safe))
- (org-narrow-to-subtree))
- ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
- (symbol-name scope)))
- (setq level (string-to-number (match-string 1 (symbol-name scope))))
- (catch 'exit
- (while (org-up-heading-safe)
- (looking-at outline-regexp)
- (if (<= (org-reduced-level (funcall outline-level)) level)
- (throw 'exit nil))))
- (org-narrow-to-subtree))
- (scope-is-list
+ (if scope-is-list
+ ;; we collect from several files
(let* ((files scope)
- (scope 'agenda)
- (p1 (copy-sequence params))
file)
- (setq p1 (plist-put p1 :tostring t))
- (setq p1 (plist-put p1 :multifile t))
- (setq p1 (plist-put p1 :scope 'file))
(org-prepare-agenda-buffers files)
(while (setq file (pop files))
(with-current-buffer (find-buffer-visiting file)
- (setq tbl1 (org-dblock-write:clocktable p1))
- (when tbl1
- (push (org-clocktable-add-file
- file
- (concat "| |*File time*|*"
- (org-minutes-to-hh:mm-string
- org-clock-file-total-minutes)
- "*|\n"
- tbl1)) tbl)
- (setq total-time (+ (or total-time 0)
- org-clock-file-total-minutes))))))))
- (goto-char pos)
-
- (unless scope-is-list
- (org-clock-sum ts te)
- (goto-char (point-min))
- (setq st t)
- (while (or (and (bobp) (prog1 st (setq st nil))
- (get-text-property (point) :org-clock-minutes)
- (setq p (point-min)))
- (setq p (next-single-property-change (point) :org-clock-minutes)))
- (goto-char p)
- (when (setq time (get-text-property p :org-clock-minutes))
- (save-excursion
- (beginning-of-line 1)
- (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@:]+:\\)?[ \t]*$"))
- (setq level (org-reduced-level
- (- (match-end 1) (match-beginning 1))))
- (<= level maxlevel))
- (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "")
- hdl (if (not link)
- (match-string 2)
- (org-make-link-string
- (format "file:%s::%s"
- (buffer-file-name)
- (save-match-data
- (org-make-org-heading-search-string
- (match-string 2))))
- (match-string 2)))
- tsp (when timestamp
- (setq props (org-entry-properties (point)))
- (or (cdr (assoc "SCHEDULED" props))
- (cdr (assoc "TIMESTAMP" props))
- (cdr (assoc "DEADLINE" props))
- (cdr (assoc "TIMESTAMP_IA" props)))))
- (if (and (not multifile) (= level 1)) (push "|-" tbl))
- (push (concat
- "| " (int-to-string level) "|"
- (if timestamp (concat tsp "|") "")
- hlc hdl hlc " |"
- (make-string (1- level) ?|)
- hlc (org-minutes-to-hh:mm-string time) hlc
- " |") tbl))))))
- (setq tbl (nreverse tbl))
- (if tostring
- (if tbl (mapconcat 'identity tbl "\n") nil)
- (goto-char ins)
- (insert-before-markers
- (or header
- (concat
- "Clock summary at ["
- (substring
- (format-time-string (cdr org-time-stamp-formats))
- 1 -1)
- "]"
- (if block (concat ", for " range-text ".") "")
- "\n\n"))
- (if scope-is-list "|File" "")
- "|L|" (if timestamp "Timestamp|" "") "Headline|Time|\n")
- (setq total-time (or total-time org-clock-file-total-minutes))
- (insert-before-markers
- "|-\n|"
- (if scope-is-list "|" "")
- (if timestamp "|Timestamp|" "|")
- "*Total time*| *"
- (org-minutes-to-hh:mm-string (or total-time 0))
- "*|\n|-\n")
- (setq tbl (delq nil tbl))
- (if (and (stringp (car tbl)) (> (length (car tbl)) 1)
- (equal (substring (car tbl) 0 2) "|-"))
- (pop tbl))
- (insert-before-markers (mapconcat
- 'identity (delq nil tbl)
- (if scope-is-list "\n|-\n" "\n")))
- (backward-delete-char 1)
- (if (setq formula (plist-get params :formula))
- (cond
- ((eq formula '%)
- (setq pcol (+ (if scope-is-list 1 0) maxlevel 3))
- (insert
- (format
- "\n#+TBLFM: $%d='(org-clock-time%% @%d$%d $%d..$%d);%%.1f"
- pcol
- 2
- (+ 3 (if scope-is-list 1 0))
- (+ (if scope-is-list 1 0) 3)
- (1- pcol)))
- (setq recalc t))
- ((stringp formula)
- (insert "\n#+TBLFM: " formula)
- (setq recalc t))
- (t (error "invalid formula in clocktable")))
- ;; Should we rescue an old formula?
- (when (stringp (setq content (plist-get params :content)))
- (when (string-match "^\\([ \t]*#\\+TBLFM:.*\\)" content)
- (setq recalc t)
- (insert "\n" (match-string 1 (plist-get params :content)))
- (beginning-of-line 0))))
- (goto-char ipos)
- (skip-chars-forward "^|")
- (org-table-align)
- (when recalc
- (if (eq formula '%)
- (save-excursion (org-table-goto-column pcol nil 'force)
- (insert "%")))
- (org-table-recalculate 'all))
- (when rm-file-column
- (forward-char 1)
- (org-table-delete-column)))))))
+ (save-excursion
+ (save-restriction
+ (push (org-clock-get-table-data file params) tbls))))))
+ ;; Just from the current file
+ (save-restriction
+ ;; get the right range into the restriction
+ (org-prepare-agenda-buffers (list (buffer-file-name)))
+ (cond
+ ((not scope)) ; use the restriction as it is now
+ ((eq scope 'file) (widen))
+ ((eq scope 'subtree) (org-narrow-to-subtree))
+ ((eq scope 'tree)
+ (while (org-up-heading-safe))
+ (org-narrow-to-subtree))
+ ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
+ (symbol-name scope)))
+ (setq level (string-to-number (match-string 1 (symbol-name scope))))
+ (catch 'exit
+ (while (org-up-heading-safe)
+ (looking-at outline-regexp)
+ (if (<= (org-reduced-level (funcall outline-level)) level)
+ (throw 'exit nil))))
+ (org-narrow-to-subtree)))
+ ;; do the table, with no file name.
+ (push (org-clock-get-table-data nil params) tbls)))
+
+ ;; OK, at this point we tbls as a list of tables, one per file
+ (setq tbls (nreverse tbls))
+
+ (setq params (plist-put params :multifile scope-is-list))
+ (setq params (plist-put params :one-file-with-archives
+ one-file-with-archives))
+
+ (funcall formatter ipos tbls params))))
+
+(defun org-clocktable-write-default (ipos tables params)
+ "Write out a clock table at position IPOS in the current buffer.
+TABLES is a list of tables with clocking data as produced by
+`org-clock-get-table-data'. PARAMS is the parameter property list obtained
+from the dynamic block defintion."
+ ;; This function looks quite complicated, mainly because there are a lot
+ ;; of options which can add or remove columns. I have massively commented
+ ;; function, to I hope it is understandable. If someone want to write
+ ;; there own special formatter, this maybe much easier because there can
+ ;; be a fixed format with a well-defined number of columns...
+ (let* ((hlchars '((1 . "*") (2 . "/")))
+ (multifile (plist-get params :multifile))
+ (block (plist-get params :block))
+ (ts (plist-get params :tstart))
+ (te (plist-get params :tend))
+ (header (plist-get params :header))
+ (narrow (plist-get params :narrow))
+ (link (plist-get params :link))
+ (maxlevel (or (plist-get params :maxlevel) 3))
+ (emph (plist-get params :emphasize))
+ (level-p (plist-get params :level))
+ (timestamp (plist-get params :timestamp))
+ (ntcol (max 1 (or (plist-get params :tcolumns) 100)))
+ (rm-file-column (plist-get params :one-file-with-archives))
+ (indent (plist-get params :indent))
+ range-text total-time tbl level hlc formula pcol
+ file-time entries entry headline
+ recalc content narrow-cut-p tcol)
+
+ ;; Implement abbreviations
+ (when (plist-get params :compact)
+ (setq level nil indent t narrow (or narrow '40!) ntcol 1))
+
+ ;; Some consistency test for parameters
+ (unless (integerp ntcol)
+ (setq params (plist-put params :tcolumns (setq ntcol 100))))
+
+ (when (and narrow (integerp narrow) link)
+ ;; We cannot have both integer narrow and link
+ (message
+ "Using hard narrowing in clocktable to allow for links")
+ (setq narrow (intern (format "%d!" narrow))))
+
+ (when narrow
+ (cond
+ ((integerp narrow))
+ ((and (symbolp narrow)
+ (string-match "\\`[0-9]+!\\'" (symbol-name narrow)))
+ (setq narrow-cut-p t
+ narrow (string-to-number (substring (symbol-name narrow)
+ 0 -1))))
+ (t
+ (error "Invalid value %s of :narrow property in clock table"
+ narrow))))
+
+ (when block
+ ;; Get the range text for the header
+ (setq range-text (nth 2 (org-clock-special-range block nil t))))
+
+ ;; Compute the total time
+ (setq total-time (apply '+ (mapcar 'cadr tables)))
+
+ ;; Now we need to output this tsuff
+ (goto-char ipos)
+
+ ;; Insert the text *before* the actual table
+ (insert-before-markers
+ (or header
+ ;; Format the standard header
+ (concat
+ "Clock summary at ["
+ (substring
+ (format-time-string (cdr org-time-stamp-formats))
+ 1 -1)
+ "]"
+ (if block (concat ", for " range-text ".") "")
+ "\n\n")))
+
+ ;; Insert the narrowing line
+ (when (and narrow (integerp narrow) (not narrow-cut-p))
+ (insert-before-markers
+ "|" ; table line starter
+ (if multifile "|" "") ; file column, maybe
+ (if level-p "|" "") ; level column, maybe
+ (if timestamp "|" "") ; timestamp column, maybe
+ (format "<%d>| |\n" narrow))) ; headline and time columns
+
+ ;; Insert the table header line
+ (insert-before-markers
+ "|" ; table line starter
+ (if multifile "File|" "") ; file column, maybe
+ (if level-p "L|" "") ; level column, maybe
+ (if timestamp "Timestamp|" "") ; timestamp column, maybe
+ "Headline|Time|\n") ; headline and time columns
+
+ ;; Insert the total time in the table
+ (insert-before-markers
+ "|-\n" ; a hline
+ "|" ; table line starter
+ (if multifile "| ALL " "") ; file column, maybe
+ (if level-p "|" "") ; level column, maybe
+ (if timestamp "|" "") ; timestamp column, maybe
+ "*Total time*| " ; instead of a headline
+ "*"
+ (org-minutes-to-hh:mm-string (or total-time 0)) ; the time
+ "*|\n") ; close line
+
+ ;; Now iterate over the tables and insert the data
+ ;; but only if any time has been collected
+ (when (and total-time (> total-time 0))
+
+ (while (setq tbl (pop tables))
+ ;; now tbl is the table resulting from one file.
+ (setq file-time (nth 1 tbl))
+ (when (or (and file-time (> file-time 0))
+ (not (plist-get params :fileskip0)))
+ (insert-before-markers "|-\n") ; a hline because a new file starts
+ ;; First the file time, if we have multiple files
+ (when multifile
+ ;; Summarize the time colleted from this file
+ (insert-before-markers
+ (format "| %s %s | %s*File time* | *%s*|\n"
+ (file-name-nondirectory (car tbl))
+ (if level-p "| " "") ; level column, maybe
+ (if timestamp "| " "") ; timestamp column, maybe
+ (org-minutes-to-hh:mm-string (nth 1 tbl))))) ; the time
+
+ ;; Get the list of node entries and iterate over it
+ (setq entries (nth 2 tbl))
+ (while (setq entry (pop entries))
+ (setq level (car entry)
+ headline (nth 1 entry)
+ hlc (if emph (or (cdr (assoc level hlchars)) "") ""))
+ (when narrow-cut-p
+ (if (and (string-match (concat "\\`" org-bracket-link-regexp
+ "\\'")
+ headline)
+ (match-end 3))
+ (setq headline
+ (format "[[%s][%s]]"
+ (match-string 1 headline)
+ (org-shorten-string (match-string 3 headline)
+ narrow)))
+ (setq headline (org-shorten-string headline narrow))))
+ (insert-before-markers
+ "|" ; start the table line
+ (if multifile "|" "") ; free space for file name column?
+ (if level-p (format "%d|" (car entry)) "") ; level, maybe
+ (if timestamp (concat (nth 2 entry) "|") "") ; timestamp, maybe
+ (if indent (org-clocktable-indent-string level) "") ; indentation
+ hlc headline hlc "|" ; headline
+ (make-string (min (1- ntcol) (or (- level 1))) ?|)
+ ; empty fields for higher levels
+ hlc (org-minutes-to-hh:mm-string (nth 3 entry)) hlc ; time
+ "|\n" ; close line
+ )))))
+ (backward-delete-char 1)
+ (if (setq formula (plist-get params :formula))
+ (cond
+ ((eq formula '%)
+ ;; compute the column where the % numbers need to go
+ (setq pcol (+ 2
+ (if multifile 1 0)
+ (if level-p 1 0)
+ (if timestamp 1 0)
+ (min maxlevel (or ntcol 100))))
+ ;; compute the column where the total time is
+ (setq tcol (+ 2
+ (if multifile 1 0)
+ (if level-p 1 0)
+ (if timestamp 1 0)))
+ (insert
+ (format
+ "\n#+TBLFM: $%d='(org-clock-time%% @%d$%d $%d..$%d);%%.1f"
+ pcol ; the column where the % numbers should go
+ (if (and narrow (not narrow-cut-p)) 3 2) ; row of the total time
+ tcol ; column of the total time
+ tcol (1- pcol) ; range of columns where times can be found
+ ))
+ (setq recalc t))
+ ((stringp formula)
+ (insert "\n#+TBLFM: " formula)
+ (setq recalc t))
+ (t (error "invalid formula in clocktable")))
+ ;; Should we rescue an old formula?
+ (when (stringp (setq content (plist-get params :content)))
+ (when (string-match "^\\([ \t]*#\\+TBLFM:.*\\)" content)
+ (setq recalc t)
+ (insert "\n" (match-string 1 (plist-get params :content)))
+ (beginning-of-line 0))))
+ ;; Back to beginning, align the table, recalculate if necessary
+ (goto-char ipos)
+ (skip-chars-forward "^|")
+ (org-table-align)
+ (when org-hide-emphasis-markers
+ ;; we need to align a second time
+ (org-table-align))
+ (when recalc
+ (if (eq formula '%)
+ (save-excursion
+ (if (and narrow (not narrow-cut-p)) (beginning-of-line 2))
+ (org-table-goto-column pcol nil 'force)
+ (insert "%")))
+ (org-table-recalculate 'all))
+ (when rm-file-column
+ ;; The file column is actually not wanted
+ (forward-char 1)
+ (org-table-delete-column))
+ total-time))
+
+(defun org-clocktable-indent-string (level)
+ (if (= level 1)
+ ""
+ (let ((str "\\__"))
+ (while (> level 2)
+ (setq level (1- level)
+ str (concat str "___")))
+ (concat str " "))))
(defun org-clocktable-steps (params)
+ "Step through the range to make a number of clock tables."
(let* ((p1 (copy-sequence params))
(ts (plist-get p1 :tstart))
(te (plist-get p1 :tend))
(step0 (plist-get p1 :step))
(step (cdr (assoc step0 '((day . 86400) (week . 604800)))))
+ (stepskip0 (plist-get p1 :stepskip0))
(block (plist-get p1 :block))
- cc range-text)
+ cc range-text step-time)
(when block
(setq cc (org-clock-special-range block nil t)
ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
- (if ts (setq ts (org-float-time
- (apply 'encode-time (org-parse-time-string ts)))))
- (if te (setq te (org-float-time
- (apply 'encode-time (org-parse-time-string te)))))
+ (cond
+ ((numberp ts)
+ ;; If ts is a number, it's an absolute day number from org-agenda.
+ (destructuring-bind (month day year) (calendar-gregorian-from-absolute ts)
+ (setq ts (org-float-time (encode-time 0 0 0 day month year)))))
+ (ts
+ (setq ts (org-float-time
+ (apply 'encode-time (org-parse-time-string ts))))))
+ (cond
+ ((numberp te)
+ ;; Likewise for te.
+ (destructuring-bind (month day year) (calendar-gregorian-from-absolute te)
+ (setq te (org-float-time (encode-time 0 0 0 day month year)))))
+ (te
+ (setq te (org-float-time
+ (apply 'encode-time (org-parse-time-string te))))))
(setq p1 (plist-put p1 :header ""))
(setq p1 (plist-put p1 :step nil))
(setq p1 (plist-put p1 :block nil))
(setq p1 (plist-put p1 :tend (format-time-string
(org-time-stamp-format nil t)
(seconds-to-time (setq ts (+ ts step))))))
- (insert "\n" (if (eq step0 'day) "Daily report: " "Weekly report starting on: ")
+ (insert "\n" (if (eq step0 'day) "Daily report: "
+ "Weekly report starting on: ")
(plist-get p1 :tstart) "\n")
- (org-dblock-write:clocktable p1)
- (re-search-forward "#\\+END:")
+ (setq step-time (org-dblock-write:clocktable p1))
+ (re-search-forward "^[ \t]*#\\+END:")
+ (when (and (equal step-time 0) stepskip0)
+ ;; Remove the empty table
+ (delete-region (point-at-bol)
+ (save-excursion
+ (re-search-backward "^\\(Daily\\|Weekly\\) report"
+ nil t)
+ (point))))
(end-of-line 0))))
-(defun org-clocktable-add-file (file table)
- (if table
- (let ((lines (org-split-string table "\n"))
- (ff (file-name-nondirectory file)))
- (mapconcat 'identity
- (mapcar (lambda (x)
- (if (string-match org-table-dataline-regexp x)
- (concat "|" ff x)
- x))
- lines)
- "\n"))))
+(defun org-clock-get-table-data (file params)
+ "Get the clocktable data for file FILE, with parameters PARAMS.
+FILE is only for identification - this function assumes that
+the correct buffer is current, and that the wanted restriction is
+in place.
+The return value will be a list with the file name and the total
+file time (in minutes) as 1st and 2nd elements. The third element
+of this list will be a list of headline entries. Each entry has the
+following structure:
+
+ (LEVEL HEADLINE TIMESTAMP TIME)
+
+LEVEL: The level of the headline, as an integer. This will be
+ the reduced leve, so 1,2,3,... even if only odd levels
+ are being used.
+HEADLINE: The text of the headline. Depending on PARAMS, this may
+ already be formatted like a link.
+TIMESTAMP: If PARAMS require it, this will be a time stamp found in the
+ entry, any of SCHEDULED, DEADLINE, NORMAL, or first inactive,
+ in this sequence.
+TIME: The sum of all time spend in this tree, in minutes. This time
+ will of cause be restricted to the time block and tags match
+ specified in PARAMS."
+ (let* ((maxlevel (or (plist-get params :maxlevel) 3))
+ (timestamp (plist-get params :timestamp))
+ (ts (plist-get params :tstart))
+ (te (plist-get params :tend))
+ (block (plist-get params :block))
+ (link (plist-get params :link))
+ (tags (plist-get params :tags))
+ (matcher (if tags (cdr (org-make-tags-matcher tags))))
+ cc range-text st p time level hdl props tsp tbl)
+
+ (setq org-clock-file-total-minutes nil)
+ (when block
+ (setq cc (org-clock-special-range block nil t)
+ ts (car cc) te (nth 1 cc) range-text (nth 2 cc)))
+ (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts)))
+ (when (integerp te) (setq te (calendar-gregorian-from-absolute te)))
+ (when (and ts (listp ts))
+ (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts))))
+ (when (and te (listp te))
+ (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te))))
+ ;; Now the times are strings we can parse.
+ (if ts (setq ts (org-float-time
+ (apply 'encode-time (org-parse-time-string ts)))))
+ (if te (setq te (org-float-time
+ (apply 'encode-time (org-parse-time-string te)))))
+ (save-excursion
+ (org-clock-sum ts te
+ (unless (null matcher)
+ (lambda ()
+ (let ((tags-list (org-get-tags-at)))
+ (eval matcher)))))
+ (goto-char (point-min))
+ (setq st t)
+ (while (or (and (bobp) (prog1 st (setq st nil))
+ (get-text-property (point) :org-clock-minutes)
+ (setq p (point-min)))
+ (setq p (next-single-property-change
+ (point) :org-clock-minutes)))
+ (goto-char p)
+ (when (setq time (get-text-property p :org-clock-minutes))
+ (save-excursion
+ (beginning-of-line 1)
+ (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))
+ (setq level (org-reduced-level
+ (- (match-end 1) (match-beginning 1))))
+ (<= level maxlevel))
+ (setq hdl (if (not link)
+ (match-string 2)
+ (org-make-link-string
+ (format "file:%s::%s"
+ (buffer-file-name)
+ (save-match-data
+ (org-make-org-heading-search-string
+ (match-string 2))))
+ (match-string 2)))
+ tsp (when timestamp
+ (setq props (org-entry-properties (point)))
+ (or (cdr (assoc "SCHEDULED" props))
+ (cdr (assoc "DEADLINE" props))
+ (cdr (assoc "TIMESTAMP" props))
+ (cdr (assoc "TIMESTAMP_IA" props)))))
+ (when (> time 0) (push (list level hdl tsp time) tbl))))))
+ (setq tbl (nreverse tbl))
+ (list file org-clock-file-total-minutes tbl))))
(defun org-clock-time% (total &rest strings)
"Compute a time fraction in percent.
(if (string-match "\\([0-9]+\\):\\([0-9]+\\)" s)
(throw 'exit
(/ (* 100.0 (+ (string-to-number (match-string 2 s))
- (* 60 (string-to-number (match-string 1 s)))))
+ (* 60 (string-to-number
+ (match-string 1 s)))))
tot))))
0))))
(buffer-file-name b)
(or (not org-clock-persist-query-save)
(y-or-n-p (concat "Save current clock ("
- (substring-no-properties org-clock-heading)
+ (substring-no-properties
+ org-clock-heading)
") "))))
(insert "(setq resume-clock '(\""
(buffer-file-name (org-clocking-buffer))
;;;###autoload
(defun org-clock-persistence-insinuate ()
- "Set up hooks for clock persistence"
+ "Set up hooks for clock persistence."
(add-hook 'org-mode-hook 'org-clock-load)
(add-hook 'kill-emacs-hook 'org-clock-save))
;; arch-tag: 7b42c5d4-9b36-48be-97c0-66a869daed4c
;;; org-clock.el ends here
+
HCoop / bpt / emacs.git / blobdiff