summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJulien Danjou <julien@danjou.info>2010-11-12 16:34:24 +0100
committerCarsten Dominik <carsten.dominik@gmail.com>2010-11-12 09:42:04 -0600
commit550859ed5a3a1985c567c9633c5e2c953f2b5b9c (patch)
treee5e68d92952383ae18138071eb419bdf44f409bb
parentaf71c1b04959e7c03f0bf6571ba7a8fc461ff55d (diff)
downloadorg-mode-550859ed5a3a1985c567c9633c5e2c953f2b5b9c.tar.gz
Introduce special face for TODAY in agenda
* lisp/org-agenda.el (org-agenda-today): New function. (org-agenda-get-day-face): New function. (org-timeline): Use org-agenda-today and org-agenda-get-day-face. (org-agenda-list): Use org-agenda-today and org-agenda-get-day-face. (org-todo-list): Use org-agenda-today. (org-get-all-dates): Use org-agenda-today. (org-agenda-day-face-function): New variable. (org-agenda-get-day-face): Use org-agenda-day-face-function. Signed-off-by: Julien Danjou <julien@danjou.info>
-rw-r--r--lisp/org-agenda.el75
1 files changed, 43 insertions, 32 deletions
diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 583e670..e2d20b5 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -1433,6 +1433,14 @@ determines if it is a foreground or a background color."
(string :tag "Color")
(sexp :tag "Face"))))))
+(defcustom org-agenda-day-face-function nil
+ "Function called to determine what face should be used to display a day.
+The only argument passed to that function is the day. It should
+returns a face, or nil if does not want to specify a face and let
+the normal rules apply."
+ :group 'org-agenda-line-format
+ :type 'function)
+
(defcustom org-agenda-category-icon-alist nil
"Alist of category icon to be displayed in agenda views.
@@ -3106,6 +3114,16 @@ no longer in use."
(progn (delete-overlay o) t)))
(overlays-in (point-min) (point-max)))))
+(defun org-agenda-get-day-face (date)
+ "Return the face DATE should be displayed with."
+ (or (and (functionp org-agenda-day-face-function)
+ (funcall org-agenda-day-face-function date))
+ (cond ((org-agenda-todayp date)
+ 'org-agenda-date-today)
+ ((member (calendar-day-of-week date) org-agenda-weekend-days)
+ 'org-agenda-date-weekend)
+ (t 'org-agenda-date))))
+
;;; Agenda timeline
(defvar org-agenda-only-exact-dates nil) ; dynamically scoped
@@ -3133,10 +3151,10 @@ dates."
org-timeline-show-empty-dates))
(org-deadline-warning-days 0)
(org-agenda-only-exact-dates t)
- (today (time-to-days (current-time)))
+ (today (org-agenda-today))
(past t)
args
- s e rtn d emptyp wd)
+ s e rtn d emptyp)
(setq org-agenda-redo-command
(list 'progn
(list 'org-switch-to-buffer-other-window (current-buffer))
@@ -3170,8 +3188,7 @@ dates."
(progn
(setq past nil)
(insert (make-string 79 ?-) "\n")))
- (setq date (calendar-gregorian-from-absolute d)
- wd (calendar-day-of-week date))
+ (setq date (calendar-gregorian-from-absolute d))
(setq s (point))
(setq rtn (and (not emptyp)
(apply 'org-agenda-get-day-entries entry
@@ -3185,9 +3202,7 @@ dates."
(funcall org-agenda-format-date date))
"\n")
(put-text-property s (1- (point)) 'face
- (if (member wd org-agenda-weekend-days)
- 'org-agenda-date-weekend
- 'org-agenda-date))
+ (org-agenda-get-day-face date))
(put-text-property s (1- (point)) 'org-date-line t)
(put-text-property s (1- (point)) 'org-agenda-date-header t)
(if (equal d today)
@@ -3213,7 +3228,7 @@ When EMPTY is non-nil, also include days without any entries."
(if inactive org-ts-regexp-both org-ts-regexp)))
dates dates1 date day day1 day2 ts1 ts2)
(if force-today
- (setq dates (list (time-to-days (current-time)))))
+ (setq dates (list (org-agenda-today))))
(save-excursion
(goto-char beg)
(while (re-search-forward re end t)
@@ -3324,9 +3339,7 @@ given in `org-agenda-start-on-weekday'."
org-agenda-start-on-weekday nil))
(thefiles (org-agenda-files nil 'ifmode))
(files thefiles)
- (today (time-to-days
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
+ (today (org-agenda-today))
(sd (or start-day today))
(start (if (or (null org-agenda-start-on-weekday)
(< org-agenda-ndays 7))
@@ -3339,7 +3352,7 @@ given in `org-agenda-start-on-weekday'."
(day-numbers (list start))
(day-cnt 0)
(inhibit-redisplay (not debug-on-error))
- s e rtn rtnall file date d start-pos end-pos todayp nd wd
+ s e rtn rtnall file date d start-pos end-pos todayp nd
clocktable-start clocktable-end filter)
(setq org-agenda-redo-command
(list 'org-agenda-list (list 'quote include-all) start-day ndays))
@@ -3397,7 +3410,6 @@ given in `org-agenda-start-on-weekday'."
(org-agenda-mark-header-line s))
(while (setq d (pop day-numbers))
(setq date (calendar-gregorian-from-absolute d)
- wd (calendar-day-of-week date)
s (point))
(if (or (setq todayp (= d today))
(and (not start-pos) (= d sd)))
@@ -3441,15 +3453,12 @@ given in `org-agenda-start-on-weekday'."
(funcall org-agenda-format-date date))
"\n")
(put-text-property s (1- (point)) 'face
- (if (member wd org-agenda-weekend-days)
- 'org-agenda-date-weekend
- 'org-agenda-date))
+ (org-agenda-get-day-face date))
(put-text-property s (1- (point)) 'org-date-line t)
(put-text-property s (1- (point)) 'org-agenda-date-header t)
(put-text-property s (1- (point)) 'org-day-cnt day-cnt)
(when todayp
- (put-text-property s (1- (point)) 'org-today t)
- (put-text-property s (1- (point)) 'face 'org-agenda-date-today))
+ (put-text-property s (1- (point)) 'org-today t))
(if rtnall (insert
(org-finalize-agenda-entries
(org-agenda-add-time-grid-maybe
@@ -3773,7 +3782,7 @@ for a keyword. A numeric prefix directly selects the Nth keyword in
(org-set-sorting-strategy 'todo)
(org-prepare-agenda "TODO")
(if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil))
- (let* ((today (time-to-days (current-time)))
+ (let* ((today (org-agenda-today))
(date (calendar-gregorian-from-absolute today))
(kwds org-todo-keywords-for-agenda)
(completion-ignore-case t)
@@ -5902,9 +5911,7 @@ Negative selection means regexp must not match for selection of an entry."
(cond
(tdpos (goto-char tdpos))
((eq org-agenda-type 'agenda)
- (let* ((sd (time-to-days
- (time-subtract (current-time)
- (list 0 (* 3600 org-extend-today-until) 0))))
+ (let* ((sd (org-agenda-today))
(comp (org-agenda-compute-time-span sd org-agenda-span))
(org-agenda-overriding-arguments org-agenda-last-arguments))
(setf (nth 1 org-agenda-overriding-arguments) (car comp))
@@ -6712,8 +6719,7 @@ the same tree node, and the headline of the tree node in the Org-mode file."
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (org-get-at-bol 'org-hd-marker))
- (todayp (equal (org-get-at-bol 'day)
- (time-to-days (current-time))))
+ (todayp (org-agenda-todayp (org-get-at-bol 'day)))
(inhibit-read-only t)
org-agenda-headline-snapshot-before-repeat newhead just-one)
(org-with-remote-undo buffer
@@ -7862,6 +7868,9 @@ belonging to the \"Work\" category."
(let* ((cnt 0) ; count added events
(org-agenda-new-buffers nil)
(org-deadline-warning-days 0)
+ ;; Do not use `org-agenda-today' here because appt only takes
+ ;; time and without date as argument, so it may pass wrong
+ ;; information otherwise
(today (org-date-to-gregorian
(time-to-days (current-time))))
(org-agenda-restrict nil)
@@ -7902,16 +7911,18 @@ belonging to the \"Work\" category."
(message "No event to add")
(message "Added %d event%s for today" cnt (if (> cnt 1) "s" "")))))
+(defun org-agenda-today ()
+ "Return today date, considering `org-extend-today-until'."
+ (time-to-days
+ (time-subtract (current-time)
+ (list 0 (* 3600 org-extend-today-until) 0))))
+
(defun org-agenda-todayp (date)
"Does DATE mean today, when considering `org-extend-today-until'?"
- (let (today h)
- (if (listp date) (setq date (calendar-absolute-from-gregorian date)))
- (setq today (calendar-absolute-from-gregorian (calendar-current-date)))
- (setq h (nth 2 (decode-time (current-time))))
- (or (and (>= h org-extend-today-until)
- (= date today))
- (and (< h org-extend-today-until)
- (= date (1- today))))))
+ (let ((today (org-agenda-today))
+ (date (if (and date (listp date)) (calendar-absolute-from-gregorian date)
+ date)))
+ (eq date today)))
(provide 'org-agenda)