summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2015-02-20 11:35:16 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2015-07-04 14:31:34 +0200
commitc76fef6b9df3ffbb6a1cf4047f391721c4076caa (patch)
tree13f206531761fb91e1e4951488549f5d1db2a1e8
parent5a3ab2a7fd32af3fbfcfd0353c39a28b9646827d (diff)
downloadorg-mode-c76fef6b9df3ffbb6a1cf4047f391721c4076caa.tar.gz
org-clock: Add `untilnow' time block
* lisp/org-clock.el (org-clock-special-range): Handle `untilnow' range. (org-clock--oldest-date): New variable. (org-clock-display-default-range): Add `untilnow' as valid range. Use new variable. (org-clock-display): Offer `untilnow' as a possible range. * doc/org.texi (The clock table): Document `untilnow' * testing/lisp/test-org-clock.el (test-org-clock-clocktable-contents-at-point): Fix test when called interactively. (test-org-clock/clocktable): (test-org-clock/clocktable1): Update tests. (test-org-clock/clocktable-until-now): New test. * etc/ORG-NEWS (title): Document new feature. Suggested-by: Sébastien Vauban
-rw-r--r--doc/org.texi1
-rw-r--r--etc/ORG-NEWS2
-rw-r--r--lisp/org-clock.el282
-rw-r--r--testing/lisp/test-org-clock.el46
4 files changed, 202 insertions, 129 deletions
diff --git a/doc/org.texi b/doc/org.texi
index 4b4dbb4..d420259 100644
--- a/doc/org.texi
+++ b/doc/org.texi
@@ -6648,6 +6648,7 @@ be selected:
thisweek, lastweek, thisweek-@var{N} @r{a relative week}
thismonth, lastmonth, thismonth-@var{N} @r{a relative month}
thisyear, lastyear, thisyear-@var{N} @r{a relative year}
+ untilnow
@r{Use @kbd{S-@key{left}/@key{right}} keys to shift the time interval.}
:tstart @r{A time string specifying when to start considering times.}
@r{Relative times like @code{"<-2w>"} can also be used. See}
diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS
index d43e9d3..4a4a9d8 100644
--- a/etc/ORG-NEWS
+++ b/etc/ORG-NEWS
@@ -399,6 +399,8 @@ set using the hh:mm:ss format.
the number of clones, which removes the repeater from the original
subtree and creates one shifted, repeating clone.
*** None-floating tables, graphics and blocks can have captions
+*** New time block for clock tables : ~untilnow~
+It encompasses all past closed clocks.
** Miscellaneous
*** Strip all meta data from ITEM special property
ITEM special property does not contain TODO, priority or tags anymore.
diff --git a/lisp/org-clock.el b/lisp/org-clock.el
index 31d6115..fb29009 100644
--- a/lisp/org-clock.el
+++ b/lisp/org-clock.el
@@ -441,6 +441,7 @@ This applies when using `org-clock-goto'."
(const lastmonth)
(const thisyear)
(const lastyear)
+ (const untilnow)
(const :tag "Select range interactively" interactive)))
(defvar org-clock-in-prepare-hook nil
@@ -460,6 +461,28 @@ to add an effort property.")
(defvar org-clock-has-been-used nil
"Has the clock been used during the current Emacs session?")
+(defconst org-clock--oldest-date
+ (let* ((dichotomy
+ (lambda (min max pred)
+ (if (funcall pred min) min
+ (incf min)
+ (while (> (- max min) 1)
+ (let ((mean (+ (ash min -1) (ash max -1) (logand min max 1))))
+ (if (funcall pred mean) (setq max mean) (setq min mean)))))
+ max))
+ (high
+ (funcall dichotomy
+ most-negative-fixnum
+ 0
+ (lambda (m) (ignore-errors (decode-time (list m 0))))))
+ (low
+ (funcall dichotomy
+ most-negative-fixnum
+ 0
+ (lambda (m) (ignore-errors (decode-time (list high m)))))))
+ (list high low))
+ "Internal time for oldest date representable on the system.")
+
;;; The clock for measuring work time.
(defvar org-mode-line-string "")
@@ -1879,9 +1902,9 @@ Use \\[org-clock-remove-overlays] to remove the subtree times."
(org-clock-remove-overlays)
(let* ((todayp (equal arg '(4)))
(customp (member arg '((16) today yesterday
- thisweek lastweek thismonth
- lastmonth thisyear lastyear
- interactive)))
+ thisweek lastweek thismonth
+ lastmonth thisyear lastyear
+ untilnow interactive)))
(prop (cond ((not arg) :org-clock-minutes-default)
(todayp :org-clock-minutes-today)
(customp :org-clock-minutes-custom)
@@ -2090,134 +2113,159 @@ buffer and update it."
(defun org-clock-special-range (key &optional time as-strings wstart mstart)
"Return two times bordering a special time range.
-Key is a symbol specifying the range and can be one of `today', `yesterday',
-`thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'.
-By default, a week starts Monday 0:00 and ends Sunday 24:00.
-The range is determined relative to TIME, which defaults to current time.
-The return value is a cons cell with two internal times like the ones
-returned by `current time' or `encode-time'.
-If AS-STRINGS is non-nil, the returned times will be formatted strings.
-If WSTART is non-nil, use this number to specify the starting day of a
-week (monday is 1).
-If MSTART is non-nil, use this number to specify the starting day of a
-month (1 is the first day of the month).
-If you can combine both, the month starting day will have priority."
- (if (integerp key) (setq key (intern (number-to-string key))))
+
+KEY is a symbol specifying the range and can be one of `today',
+`yesterday', `thisweek', `lastweek', `thismonth', `lastmonth',
+`thisyear', `lastyear' or `untilnow'. If set to `interactive',
+user is prompted for range boundaries. It can be a string or an
+integer.
+
+By default, a week starts Monday 0:00 and ends Sunday 24:00. The
+range is determined relative to TIME, which defaults to current
+time.
+
+The return value is a list containing two internal times, one for
+the beginning of the range and one for its end, like the ones
+returned by `current time' or `encode-time' and a string used to
+display information. If AS-STRINGS is non-nil, the returned
+times will be formatted strings.
+
+If WSTART is non-nil, use this number to specify the starting day
+of a week (monday is 1). If MSTART is non-nil, use this number
+to specify the starting day of a month (1 is the first day of the
+month). If you can combine both, the month starting day will
+have priority."
(let* ((tm (decode-time (or time (current-time))))
- (s 0) (m (nth 1 tm)) (h (nth 2 tm))
- (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm))
+ (m (nth 1 tm))
+ (h (nth 2 tm))
+ (d (nth 3 tm))
+ (month (nth 4 tm))
+ (y (nth 5 tm))
(dow (nth 6 tm))
- (ws (or wstart 1))
- (ms (or mstart 1))
- (skey (symbol-name key))
+ (skey (format "%s" key))
(shift 0)
- (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)
+ (q (cond ((>= month 10) 4)
+ ((>= month 7) 3)
+ ((>= month 4) 2)
+ (t 1)))
+ m1 h1 d1 month1 y1 shiftedy shiftedm shiftedq)
(cond
- ((string-match "^[0-9]+$" skey)
- (setq y (string-to-number skey) m 1 d 1 key 'year))
- ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)$" skey)
+ ((string-match "\\`[0-9]+\\'" skey)
+ (setq y (string-to-number skey) month 1 d 1 key 'year))
+ ((string-match "\\`\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)\\'" skey)
(setq y (string-to-number (match-string 1 skey))
month (string-to-number (match-string 2 skey))
- d 1 key 'month))
- ((string-match "^\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)$" skey)
+ d 1
+ key 'month))
+ ((string-match "\\`\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)\\'" skey)
(require 'cal-iso)
- (setq y (string-to-number (match-string 1 skey))
- w (string-to-number (match-string 2 skey)))
- (setq date (calendar-gregorian-from-absolute
- (calendar-iso-to-absolute (list w 1 y))))
- (setq d (nth 1 date) month (car date) y (nth 2 date)
- dow 1
- key 'week))
- ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey)
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-iso-to-absolute
+ (list (string-to-number (match-string 2 skey))
+ 1
+ (string-to-number (match-string 1 skey)))))))
+ (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-iso-to-absolute (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)
+ (let ((date (calendar-gregorian-from-absolute
+ (calendar-iso-to-absolute
+ (org-quarter-to-date
+ (string-to-number (match-string 2 skey))
+ (string-to-number (match-string 1 skey)))))))
+ (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))
d (string-to-number (match-string 3 skey))
key 'day))
- ((string-match "\\([-+][0-9]+\\)$" skey)
+ ((string-match "\\([-+][0-9]+\\)\\'" skey)
(setq shift (string-to-number (match-string 1 skey))
- key (intern (substring skey 0 (match-beginning 1))))
- (if (and (memq key '(quarter thisq)) (> shift 0))
- (error "Looking forward with quarters isn't implemented"))))
-
+ key (intern (substring skey 0 (match-beginning 1))))
+ (when (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))
- ((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))
- ((memq key '(week thisweek))
- (setq diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws)))
- m 0 h 0 d (- d diff) d1 (+ 7 d)))
- ((memq key '(month thismonth))
- (setq d (or ms 1) h 0 m 0 d1 (or ms 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 within 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)))
- ((eq key 'interactive) nil)
- (t (user-error "No such time block %s" key)))
- (setq ts (encode-time s m h d month y)
- te (encode-time (or s1 s) (or m1 m) (or h1 h)
- (or d1 d) (or month1 month) (or y1 y)))
- (setq fm (cdr org-time-stamp-formats))
- (cond
- ((memq key '(day today))
- (setq txt (format-time-string "%A, %B %d, %Y" ts)))
- ((memq key '(week thisweek))
- (setq txt (format-time-string "week %G-W%V" ts)))
- ((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)))
- ((memq key '(quarter thisq))
- (setq txt (concat (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)
- (if (eq key 'interactive)
- (list (org-read-date nil t nil "Range start? ")
- (org-read-date nil t nil "Range end? ")
- "(Range interactively set)")
- (list ts te txt)))))
+ (case key
+ (yesterday (setq key 'today shift -1))
+ (lastweek (setq key 'week shift -1))
+ (lastmonth (setq key 'month shift -1))
+ (lastyear (setq key 'year shift -1))
+ (lastq (setq key 'quarter shift -1))))
+ ;; Prepare start and end times depending on KEY's type.
+ (case key
+ ((day today) (setq m 0 h 0 h1 24 d (+ d shift)))
+ ((week thisweek)
+ (let* ((ws (or wstart 1))
+ (diff (+ (* -7 shift) (if (= dow 0) (- 7 ws) (- dow ws)))))
+ (setq m 0 h 0 d (- d diff) d1 (+ 7 d))))
+ ((month thismonth)
+ (setq h 0 m 0 d (or mstart 1) month (+ month shift) month1 (1+ month)))
+ ((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.
+ (let* ((interval (* -1 (+ (- q 1) shift)))
+ ;; Set tmp to ((years to shift) (quarters to shift)).
+ (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 m 0 h 0 d 1 month shiftedm month1 (+ 3 shiftedm) y shiftedy))
+ ((> (+ q shift) 0) ; Shift is within this year.
+ (setq shiftedq (+ q shift))
+ (setq shiftedy y)
+ (let ((qshift (* 3 (1- (+ q shift)))))
+ (setq m 0 h 0 d 1 month (+ 1 qshift) month1 (+ 4 qshift))))))
+ ((year thisyear)
+ (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y)))
+ ((interactive untilnow)) ; Special cases, ignore them.
+ (t (user-error "No such time block %s" key)))
+ ;; Format start and end times according to AS-STRINGS.
+ (let* ((start (case key
+ (interactive (org-read-date nil t nil "Range start? "))
+ (untilnow org-clock--oldest-date)
+ (t (encode-time 0 m h d month y))))
+ (end (case key
+ (interactive (org-read-date nil t nil "Range end? "))
+ (untilnow (current-time))
+ (t (encode-time 0
+ (or m1 m)
+ (or h1 h)
+ (or d1 d)
+ (or month1 month)
+ (or y1 y)))))
+ (text
+ (case key
+ ((day today) (format-time-string "%A, %B %d, %Y" start))
+ ((week thisweek) (format-time-string "week %G-W%V" start))
+ ((month thismonth) (format-time-string "%B %Y" start))
+ ((year thisyear) (format-time-string "the year %Y" start))
+ ((quarter thisq)
+ (concat (org-count-quarter shiftedq)
+ " quarter of " (number-to-string shiftedy)))
+ (interactive "(Range interactively set)")
+ (untilnow "now"))))
+ (if (not as-strings) (list start end text)
+ (let ((f (cdr org-time-stamp-formats)))
+ (list (format-time-string f start)
+ (format-time-string f end)
+ text))))))
(defun org-count-quarter (n)
(cond
diff --git a/testing/lisp/test-org-clock.el b/testing/lisp/test-org-clock.el
index ad15fe4..f6838cd 100644
--- a/testing/lisp/test-org-clock.el
+++ b/testing/lisp/test-org-clock.el
@@ -20,13 +20,13 @@ INPUT is a string as expected in a date/time prompt, i.e \"+2d\"
or \"2/5\".
When optional argument INACTIVE is non-nil, return an inactive
-timestamp. When optional argument WITH-TIME is non-nil, also
+timestamp. When optional argument WITH-TIME is non-nil, also
insert hours and minutes.
Return the timestamp as a string."
(org-element-interpret-data
(let ((time (decode-time
- (apply 'encode-time
+ (apply #'encode-time
(mapcar (lambda (el) (or el 0))
(org-read-date-analyze
input nil (decode-time (current-time))))))))
@@ -64,21 +64,21 @@ OPTIONS is a string of clocktable options. Caption is ignored in
contents. The clocktable doesn't appear in the buffer."
(save-excursion
(insert "#+BEGIN: clocktable " options "\n")
- (insert "#+END: clocktable\n"))
+ (insert "#+END:\n"))
(unwind-protect
(save-excursion
- (org-update-dblock)
+ (let ((org-time-clocksum-format
+ '(:hours "%d" :require-hours t :minutes ":%02d"
+ :require-minutes t)))
+ (org-update-dblock))
(forward-line)
;; Skip caption.
(when (looking-at "#\\+CAPTION:") (forward-line))
(buffer-substring (point)
- (progn (search-forward "#+END: clocktable")
+ (progn (search-forward "#+END:")
(match-beginning 0))))
;; Remove clocktable.
- (delete-region (point)
- (progn (search-forward "#+END: clocktable")
- (forward-line)
- (point)))))
+ (delete-region (point) (search-forward "#+END:\n"))))
@@ -94,10 +94,13 @@ contents. The clocktable doesn't appear in the buffer."
;; Install Clock lines in "Bar".
(search-forward "** Bar")
(forward-line)
+ (insert (org-test-clock-create-clock "-10y 8:00" "-10y 12:00"))
(insert (org-test-clock-create-clock "-2d 15:00" "-2d 18:00"))
(insert (org-test-clock-create-clock "-1d 8:00" "-1d 13:00"))
(insert (org-test-clock-create-clock "-1d 15:00" "-1d 18:00"))
- (insert (org-test-clock-create-clock ". 15:00"))
+ (insert (org-test-clock-create-clock
+ (let ((time (decode-time (current-time))))
+ (format ". %d:%d" (1- (nth 2 time)) (nth 1 time)))))
;; Previous two days.
(goto-char (point-min))
(forward-line)
@@ -117,7 +120,8 @@ contents. The clocktable doesn't appear in the buffer."
"
(org-test-with-temp-text
"* Relative times in clocktable\n** Foo\n** Bar\n"
- (test-org-clock/clocktable ":tstart \"<today-2>\" :tend \"<today>\" :indent nil")))))
+ (test-org-clock/clocktable
+ ":tstart \"<-2d>\" :tend \"<today>\" :indent nil")))))
(ert-deftest test-org-clock/clocktable2 ()
"Test clocktable specifications."
;; Relative time: Yesterday until now.
@@ -133,7 +137,25 @@ contents. The clocktable doesn't appear in the buffer."
"
(org-test-with-temp-text
"* Relative times in clocktable\n** Foo\n** Bar\n"
- (test-org-clock/clocktable ":tstart \"<yesterday>\" :tend \"<tomorrow>\" :indent nil")))))
+ (test-org-clock/clocktable
+ ":tstart \"<yesterday>\" :tend \"<tomorrow>\" :indent nil")))))
+
+(ert-deftest test-org-clock/clocktable-until-now ()
+ "Test clocktable specifications using `untilnow' range."
+ ;; Relative time: Yesterday until now.
+ (should
+ (equal
+ "| Headline | Time | |
+|------------------------------+---------+-------|
+| *Total time* | *25:00* | |
+|------------------------------+---------+-------|
+| Relative times in clocktable | 25:00 | |
+| Foo | | 10:00 |
+| Bar | | 15:00 |
+"
+ (org-test-with-temp-text
+ "* Relative times in clocktable\n** Foo\n** Bar\n"
+ (test-org-clock/clocktable ":block untilnow :indent nil")))))
(provide 'test-org-clock)
;;; test-org-clock.el end here