tec/org-mode
tec
/
org-mode
forked from mirrors/org-mode
1
0
Fork 0
Code Pull Requests Releases Activity

org-agenda: Fix `org-agenda-get-scheduled' 

* lisp/org-agenda.el (org-agenda-get-scheduled): Rewrite function.
  Comment code.  Fix fontification and sorting issues introduced in
  9e18583.
This commit is contained in:
Nicolas Goaziou 2015-10-28 14:41:31 +01:00
parent 10a3d601ec
commit 72c3f5e8e5
1 changed files with 157 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

314
lisp/org-agenda.el
View File

@ -6175,10 +6175,11 @@ FRACTION is what fraction of the head-warning time has passed."
(while (setq f (pop faces)) (while (setq f (pop faces))
(if (>= fraction (car f)) (throw 'exit (cdr f))))))) (if (>= fraction (car f)) (throw 'exit (cdr f)))))))
(defun org-agenda-get-scheduled (&optional deadline-results with-hour) (defun org-agenda-get-scheduled (&optional deadlines with-hour)
"Return the scheduled information for agenda display. "Return the scheduled information for agenda display.
When WITH-HOUR is non-nil, only return scheduled items with Optional argument DEADLINES is a list of deadline items to be
an hour specification like [h]h:mm." displayed in agenda view. When WITH-HOUR is non-nil, only return
scheduled items with an hour specification like [h]h:mm."
(let* ((props (list 'org-not-done-regexp org-not-done-regexp (let* ((props (list 'org-not-done-regexp org-not-done-regexp
'org-todo-regexp org-todo-regexp 'org-todo-regexp org-todo-regexp
'org-complex-heading-regexp org-complex-heading-regexp 'org-complex-heading-regexp org-complex-heading-regexp
@ -6190,171 +6191,170 @@ an hour specification like [h]h:mm."
(regexp (if with-hour (regexp (if with-hour
org-scheduled-time-hour-regexp org-scheduled-time-hour-regexp
org-scheduled-time-regexp)) org-scheduled-time-regexp))
(todayp (org-agenda-todayp date)) ; DATE bound by calendar (todayp (org-agenda-today-p date)) ; DATE bound by calendar.
(d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar (current (calendar-absolute-from-gregorian date))
mm (deadline-pos
(deadline-position-alist (mapcar (lambda (d)
(mapcar (lambda (a) (and (setq mm (get-text-property (let ((m (get-text-property 0 'org-hd-marker d)))
0 'org-hd-marker a)) (and m (marker-position m))))
(cons (marker-position mm) a))) deadlines))
deadline-results)) scheduled-items)
d2 diff pos pos1 category level tags donep
ee txt head pastschedp todo-state face timestr s habitp show-all
did-habit-check-p warntime inherited-tags ts-date suppress-delay
ddays)
(goto-char (point-min)) (goto-char (point-min))
(while (re-search-forward regexp nil t) (while (re-search-forward regexp nil t)
(catch :skip (catch :skip
(unless (save-match-data (org-at-planning-p)) (throw :skip nil)) (unless (save-match-data (org-at-planning-p)) (throw :skip nil))
(org-agenda-skip) (org-agenda-skip)
(setq s (match-string 1) (let* ((s (match-string 1))
txt nil (pos (1- (match-beginning 1)))
pos (1- (match-beginning 1)) (todo-state (save-match-data (org-get-todo-state)))
todo-state (save-match-data (org-get-todo-state)) (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
show-all (or (eq org-agenda-repeating-timestamp-show-all t) (member todo-state
(member todo-state org-agenda-repeating-timestamp-show-all)))
org-agenda-repeating-timestamp-show-all)) ;; SCHEDULE is the current scheduled date. When it
d2 (org-time-string-to-absolute ;; contains a repeater and SHOW-ALL is non-nil,
s d1 'past show-all (current-buffer) pos) ;; LAST-REPEAT is the repeat closest to CURRENT.
diff (- d2 d1) ;; Otherwise, LAST-REPEAT is equal to SCHEDULE.
warntime (get-text-property (point) 'org-appt-warntime)) (last-repeat (org-time-string-to-absolute
(setq pastschedp (and todayp (< diff 0))) s current 'past show-all (current-buffer) pos))
(setq did-habit-check-p nil) (schedule (org-time-string-to-absolute s))
(setq suppress-delay (diff (- last-repeat current))
(let ((ds (and org-agenda-skip-scheduled-delay-if-deadline (warntime (get-text-property (point) 'org-appt-warntime))
(let ((item (buffer-substring (point-at-bol) (point-at-eol)))) (pastschedp (< schedule (org-today)))
(save-match-data (habitp (and (fboundp 'org-is-habit-p) (org-is-habit-p)))
(and (string-match (suppress-delay
org-deadline-time-regexp item) (let ((deadline (and org-agenda-skip-scheduled-delay-if-deadline
(match-string 1 item))))))) (org-entry-get nil "DEADLINE"))))
(cond
((not deadline) nil)
;; The current item has a deadline date, so
;; evaluate its delay time.
((integerp org-agenda-skip-scheduled-delay-if-deadline)
;; Use global delay time.
(- org-agenda-skip-scheduled-delay-if-deadline))
((eq org-agenda-skip-scheduled-delay-if-deadline
'post-deadline)
;; Set delay to no later than DEADLINE. If
;; DEADLINE has a repeater, compare last schedule
;; repeat and last deadline repeat.
(min (- last-repeat
(org-time-string-to-absolute
deadline current 'past show-all
(current-buffer)
(save-excursion
(beginning-of-line)
(1+ (search-forward org-deadline-string)))))
org-scheduled-delay-days))
(t 0))))
(ddays
(cond (cond
((not ds) nil) ;; Nullify delay when a repeater triggered already
;; The current item has a deadline date (in ds), so ;; and the delay is of the form --Xd.
;; evaluate its delay time. ((and (save-match-data (string-match "--[0-9]+[hdwmy]" s))
((integerp org-agenda-skip-scheduled-delay-if-deadline) (/= schedule last-repeat))
;; Use global delay time. 0)
(- org-agenda-skip-scheduled-delay-if-deadline)) (suppress-delay
((eq org-agenda-skip-scheduled-delay-if-deadline (let ((org-scheduled-delay-days suppress-delay))
'post-deadline) (org-get-wdays s t t)))
;; Set delay to no later than deadline. (t (org-get-wdays s t)))))
(min (- d2 (org-time-string-to-absolute ;; Only show a scheduled item in the calendar if it is on or
ds d1 'past show-all (current-buffer) pos)) ;; past the current date. Skip it if it has been displayed
org-scheduled-delay-days)) ;; for more than `org-scheduled-past-days'.
(t 0)))) (unless (or (and (>= ddays 0) (= diff (- ddays)))
(setq ddays (if suppress-delay (and (< (+ diff ddays) 0)
(let ((org-scheduled-delay-days suppress-delay)) (< (abs diff) org-scheduled-past-days)
(org-get-wdays s t t)) (and todayp (not org-agenda-only-exact-dates)))
(org-get-wdays s t))) (and todayp
;; Use a delay of 0 when there is a repeater and the delay is habitp
;; of the form --3d (bound-and-true-p org-habit-show-all-today)))
(when (and (save-match-data (string-match "--[0-9]+[hdwmy]" s)) (throw :skip nil))
(< (org-time-string-to-absolute s) ;; Skip done habits, or tasks if
(org-time-string-to-absolute ;; `org-agenda-skip-deadline-if-done' is non-nil or if it
s d2 'past nil (current-buffer) pos))) ;; was scheduled in the past anyway.
(setq ddays 0)) (let ((donep (member todo-state org-done-keywords)))
;; When to show a scheduled item in the calendar: (when (and donep
;; If it is on or past the date. (or org-agenda-skip-scheduled-if-done
(when (or (and (> ddays 0) (= diff (- ddays))) (/= schedule current)
(and (zerop ddays) (= diff 0)) habitp))
(and (< (+ diff ddays) 0) (throw :skip nil))
(< (abs diff) org-scheduled-past-days) ;; Skip entry if it already appears as a deadline, per
(and todayp (not org-agenda-only-exact-dates))) ;; `org-agenda-skip-scheduled-if-deadline-is-shown'. This
;; org-is-habit-p uses org-entry-get, which is expansive ;; doesn't apply to habits.
;; so we go extra mile to only call it once (when (pcase org-agenda-skip-scheduled-if-deadline-is-shown
(and todayp ((guard
(boundp 'org-habit-show-all-today) (or (not (assq (line-beginning-position 0) deadline-pos))
org-habit-show-all-today habitp))
(setq did-habit-check-p t) nil)
(setq habitp (and (functionp 'org-is-habit-p) (`repeated-after-deadline
(org-is-habit-p))))) (>= last-repeat
(save-excursion (time-to-days (org-get-deadline-time (point)))))
(setq donep (member todo-state org-done-keywords)) (`not-today pastschedp)
(if (and donep (`t t)
(or org-agenda-skip-scheduled-if-done (_ nil))
(not (= diff 0)) (throw :skip nil))
(and (functionp 'org-is-habit-p) ;; Skip habits if `org-habit-show-habits' is nil, or if we
(org-is-habit-p)))) ;; only show them for today.
(setq txt nil) (when (and habitp
(setq habitp (if did-habit-check-p habitp (or (not (bound-and-true-p org-habit-show-habits))
(and (functionp 'org-is-habit-p) (and (not todayp)
(org-is-habit-p)))) (bound-and-true-p
(setq category (org-get-category)) org-habit-show-habits-only-for-today))))
(if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown (throw :skip nil))
'repeated-after-deadline) (save-excursion
(org-get-deadline-time (point)) (re-search-backward "^\\*+[ \t]+" nil t)
(<= 0 (- d2 (time-to-days (org-get-deadline-time (point)))))) (goto-char (match-end 0))
(throw :skip nil)) (let* ((category (org-get-category))
(if (not (re-search-backward "^\\*+[ \t]+" nil t)) (inherited-tags
(throw :skip nil)
(goto-char (match-end 0))
(setq pos1 (match-beginning 0))
(if habitp
(if (or (not org-habit-show-habits)
(and (not todayp)
(boundp 'org-habit-show-habits-only-for-today)
org-habit-show-habits-only-for-today))
(throw :skip nil))
(if (and
(or (eq t org-agenda-skip-scheduled-if-deadline-is-shown)
(and (eq org-agenda-skip-scheduled-if-deadline-is-shown 'not-today)
pastschedp))
(setq mm (assoc pos1 deadline-position-alist)))
(throw :skip nil)))
(setq inherited-tags
(or (eq org-agenda-show-inherited-tags 'always) (or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags) (and (listp org-agenda-show-inherited-tags)
(memq 'agenda org-agenda-show-inherited-tags)) (memq 'agenda org-agenda-show-inherited-tags))
(and (eq org-agenda-show-inherited-tags t) (and (eq org-agenda-show-inherited-tags t)
(or (eq org-agenda-use-tag-inheritance t) (or (eq org-agenda-use-tag-inheritance t)
(memq 'agenda org-agenda-use-tag-inheritance)))) (memq 'agenda
org-agenda-use-tag-inheritance)))))
tags (org-get-tags-at nil (not inherited-tags))) (tags (org-get-tags-at nil (not inherited-tags)))
(setq level (make-string (org-reduced-level (org-outline-level)) ? )) (level
(setq head (buffer-substring (make-string (org-reduced-level (org-outline-level))
(point) ?\s))
(progn (skip-chars-forward "^\r\n") (point)))) (head (buffer-substring (point) (line-end-position)))
(if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s) (timestr
(setq timestr (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
(concat (substring s (match-beginning 1)) " ")) (concat (substring s (match-beginning 1)) " ")
(setq timestr 'time)) 'time))
(setq txt (org-agenda-format-item (item (org-agenda-format-item
;; For past scheduled dates, make sure to ;; For past scheduled dates, make sure to
;; report time difference since date S, not ;; report time difference since SCHEDULE,
;; since closest repeater. ;; not since closest repeater.
(let ((diff (let ((diff (if (< (org-today) current) diff
(if (< (org-today) d1) diff (- schedule current))))
(- (org-time-string-to-absolute s) d1)))) (if (= diff 0) (car org-agenda-scheduled-leaders)
(if (= diff 0) (car org-agenda-scheduled-leaders) (format (nth 1 org-agenda-scheduled-leaders)
(format (nth 1 org-agenda-scheduled-leaders) (- 1 diff))))
(- 1 diff)))) head level category tags
head level category tags (and (= diff 0) timestr)
(and (= diff 0) timestr) nil habitp)))
nil habitp)))) (when item
(when txt (let ((face (cond ((and (not habitp) pastschedp)
(setq face 'org-scheduled-previously)
(cond (todayp 'org-scheduled-today)
((and (not habitp) pastschedp) (t 'org-scheduled)))
'org-scheduled-previously) (habitp (and habitp (org-habit-parse-todo))))
(todayp 'org-scheduled-today) (org-add-props item props
(t 'org-scheduled)) 'undone-face face
habitp (and habitp (org-habit-parse-todo))) 'face (if donep 'org-agenda-done face)
(org-add-props txt props 'org-marker (org-agenda-new-marker pos)
'undone-face face 'org-hd-marker (org-agenda-new-marker
'face (if donep 'org-agenda-done face) (line-beginning-position))
'org-marker (org-agenda-new-marker pos) 'type (if pastschedp "past-scheduled" "scheduled")
'org-hd-marker (org-agenda-new-marker pos1) 'date (if pastschedp schedule date)
'type (if pastschedp "past-scheduled" "scheduled") 'ts-date schedule
'date (if pastschedp d2 date) 'warntime warntime
'ts-date d2 'level level
'warntime warntime 'priority (if habitp (org-habit-get-priority habitp)
'level level (+ 94 (- 5 diff) (org-get-priority item)))
'priority (if habitp 'org-habit-p habitp
(org-habit-get-priority habitp) 'todo-state todo-state))
(+ 94 (- 5 diff) (org-get-priority txt))) (push item scheduled-items))))))))
'org-habit-p habitp (nreverse scheduled-items)))
'todo-state todo-state)
(push txt ee))))))
(nreverse ee)))
(defun org-agenda-get-blocks () (defun org-agenda-get-blocks ()
"Return the date-range information for agenda display." "Return the date-range information for agenda display."