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>

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)