From mboxrd@z Thu Jan 1 00:00:00 1970 From: Julien Danjou Subject: Re: [PATCH 1/2] org-agenda: introduce org-agenda-today and org-agenda-get-day-face Date: Tue, 09 Nov 2010 11:59:03 +0100 Message-ID: References: <1289236987-21552-1-git-send-email-julien@danjou.info> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from [140.186.70.92] (port=47790 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PFlv6-0001lP-4h for emacs-orgmode@gnu.org; Tue, 09 Nov 2010 05:59:28 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PFluv-00052J-Lp for emacs-orgmode@gnu.org; Tue, 09 Nov 2010 05:59:19 -0500 Received: from coquelicot-s.easter-eggs.com ([213.215.37.94]:50745) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1PFlut-00051l-KJ for emacs-orgmode@gnu.org; Tue, 09 Nov 2010 05:59:09 -0500 Received: from cigue.easter-eggs.fr (cigue.easter-eggs.fr [10.0.0.33]) by rose.easter-eggs.fr (Postfix) with ESMTPS id 31A211427A for ; Tue, 9 Nov 2010 11:59:02 +0100 (CET) Received: from jdanjou by cigue.easter-eggs.fr with local (Exim 4.72) (envelope-from ) id 1PFlup-00021s-Ui for emacs-orgmode@gnu.org; Tue, 09 Nov 2010 11:59:03 +0100 In-Reply-To: <1289236987-21552-1-git-send-email-julien@danjou.info> (Julien Danjou's message of "Mon, 8 Nov 2010 18:23:06 +0100") List-Id: "General discussions about Org-mode." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Sender: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org Errors-To: emacs-orgmode-bounces+geo-emacs-orgmode=m.gmane.org@gnu.org To: emacs-orgmode@gnu.org --=-=-= Content-Type: text/plain On Mon, Nov 08 2010, Julien Danjou wrote: I just noticed a little bug if org-agenda-todayp is called with nil as argument. Here's a fixed version of that patch. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-org-agenda-introduce-org-agenda-today-and-org-agenda.patch >From c93cf37f9c41f3fb71fd44e0ce2a4c9ba30224cc Mon Sep 17 00:00:00 2001 From: Julien Danjou Date: Mon, 8 Nov 2010 15:25:22 +0100 Subject: [PATCH] org-agenda: introduce org-agenda-today and org-agenda-get-day-face * org-agenda (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. Signed-off-by: Julien Danjou --- lisp/org-agenda.el | 65 ++++++++++++++++++++++++++------------------------- 1 files changed, 33 insertions(+), 32 deletions(-) diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el index 583e670..b7f38ca 100644 --- a/lisp/org-agenda.el +++ b/lisp/org-agenda.el @@ -3106,6 +3106,14 @@ 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." + (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 +3141,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 +3178,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 +3192,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 +3218,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 +3329,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 +3342,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 +3400,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 +3443,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 +3772,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 +5901,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 +6709,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 +7858,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 +7901,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) -- 1.7.2.3 --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable --=20 Julien Danjou // =E1=90=B0 http://julien.danjou.info --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Emacs-orgmode mailing list Please use `Reply All' to send replies to the list. Emacs-orgmode@gnu.org http://lists.gnu.org/mailman/listinfo/emacs-orgmode --=-=-=--