From fad280debe2dd1cb59071f258153004f1dffd51e Mon Sep 17 00:00:00 2001
From: Nicolas Goaziou <mail@nicolasgoaziou.fr>
Date: Thu, 4 Sep 2014 21:41:40 +0200
Subject: [PATCH] org-agenda: Prevent false positive SCHEDULED entries

---
 lisp/org-agenda.el | 292 ++++++++++++++++++++++++++---------------------------
 lisp/org.el        |  82 +++++++++------
 2 files changed, 195 insertions(+), 179 deletions(-)

diff --git a/lisp/org-agenda.el b/lisp/org-agenda.el
index 4b6385b..3d6ecac 100644
--- a/lisp/org-agenda.el
+++ b/lisp/org-agenda.el
@@ -6143,7 +6143,7 @@ an hour specification like [h]h:mm."
 		     org-scheduled-time-hour-regexp
 		   org-scheduled-time-regexp))
 	 (todayp (org-agenda-todayp date)) ; DATE bound by calendar
-	 (d1 (calendar-absolute-from-gregorian date))  ; DATE bound by calendar
+	 (d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
 	 mm
 	 (deadline-position-alist
 	  (mapcar (lambda (a) (and (setq mm (get-text-property
@@ -6156,153 +6156,153 @@ an hour specification like [h]h:mm."
 	 ddays)
     (goto-char (point-min))
     (while (re-search-forward regexp nil t)
-      (catch :skip
-	(org-agenda-skip)
-	(setq s (match-string 1)
-	      txt nil
-	      pos (1- (match-beginning 1))
-	      todo-state (save-match-data (org-get-todo-state))
-	      show-all (or (eq org-agenda-repeating-timestamp-show-all t)
-			   (member todo-state
-				   org-agenda-repeating-timestamp-show-all))
-	      d2 (org-time-string-to-absolute
-		  s d1 'past show-all (current-buffer) pos)
-	      diff (- d2 d1)
-	      warntime (get-text-property (point) 'org-appt-warntime))
-	(setq pastschedp (and todayp (< diff 0)))
-	(setq did-habit-check-p nil)
-	(setq suppress-delay
-	      (let ((ds (and org-agenda-skip-scheduled-delay-if-deadline
-			     (let ((item (buffer-substring (point-at-bol) (point-at-eol))))
-			       (save-match-data
-				 (and (string-match
-				       org-deadline-time-regexp item)
-				      (match-string 1 item)))))))
-		(cond
-		 ((not ds) nil)
-		 ;; The current item has a deadline date (in ds), 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.
-		  (min (- d2 (org-time-string-to-absolute
-			      ds d1 'past show-all (current-buffer) pos))
-		       org-scheduled-delay-days))
-		 (t 0))))
-	(setq ddays (if suppress-delay
-			(let ((org-scheduled-delay-days suppress-delay))
-			  (org-get-wdays s t t))
-		      (org-get-wdays s t)))
-	;; Use a delay of 0 when there is a repeater and the delay is
-	;; of the form --3d
-	(when (and (save-match-data (string-match "--[0-9]+[hdwmy]" s))
-		   (< (org-time-string-to-absolute s)
-		      (org-time-string-to-absolute
-		       s d2 'past nil (current-buffer) pos)))
-	  (setq ddays 0))
-	;; When to show a scheduled item in the calendar:
-	;; If it is on or past the date.
-	(when (or (and (> ddays 0) (= diff (- ddays)))
-		  (and (zerop ddays) (= diff 0))
-		  (and (< (+ diff ddays) 0)
-		       (< (abs diff) org-scheduled-past-days)
-		       (and todayp (not org-agenda-only-exact-dates)))
-		  ;; org-is-habit-p uses org-entry-get, which is expansive
-		  ;; so we go extra mile to only call it once
-		  (and todayp
-		       (boundp 'org-habit-show-all-today)
-		       org-habit-show-all-today
-		       (setq did-habit-check-p t)
-		       (setq habitp (and (functionp 'org-is-habit-p)
-					 (org-is-habit-p)))))
-	  (save-excursion
-	    (setq donep (member todo-state org-done-keywords))
-	    (if (and donep
-		     (or org-agenda-skip-scheduled-if-done
-			 (not (= diff 0))
-			 (and (functionp 'org-is-habit-p)
-			      (org-is-habit-p))))
-		(setq txt nil)
-	      (setq habitp (if did-habit-check-p habitp
+      (let ((s (save-match-data (org-entry-get (point) "SCHEDULED"))))
+	(when s
+	  (catch :skip
+	    (org-agenda-skip)
+	    (setq txt nil
+		  pos (1- (match-beginning 1))
+		  todo-state (save-match-data (org-get-todo-state))
+		  show-all (or (eq org-agenda-repeating-timestamp-show-all t)
+			       (member todo-state
+				       org-agenda-repeating-timestamp-show-all))
+		  d2 (org-time-string-to-absolute
+		      s d1 'past show-all (current-buffer) pos)
+		  diff (- d2 d1)
+		  warntime (get-text-property (point) 'org-appt-warntime))
+	    (setq pastschedp (and todayp (< diff 0)))
+	    (setq did-habit-check-p nil)
+	    (setq suppress-delay
+		  (let ((ds (and org-agenda-skip-scheduled-delay-if-deadline
+				 (let ((item (buffer-substring (point-at-bol) (point-at-eol))))
+				   (save-match-data
+				     (and (string-match
+					   org-deadline-time-regexp item)
+					  (match-string 1 item)))))))
+		    (cond
+		     ((not ds) nil)
+		     ;; The current item has a deadline date (in ds), 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.
+		      (min (- d2 (org-time-string-to-absolute
+				  ds d1 'past show-all (current-buffer) pos))
+			   org-scheduled-delay-days))
+		     (t 0))))
+	    (setq ddays (if suppress-delay
+			    (let ((org-scheduled-delay-days suppress-delay))
+			      (org-get-wdays s t t))
+			  (org-get-wdays s t)))
+	    ;; Use a delay of 0 when there is a repeater and the delay is
+	    ;; of the form --3d
+	    (when (and (save-match-data (string-match "--[0-9]+[hdwmy]" s))
+		       (< (org-time-string-to-absolute s)
+			  (org-time-string-to-absolute
+			   s d2 'past nil (current-buffer) pos)))
+	      (setq ddays 0))
+	    ;; When to show a scheduled item in the calendar:
+	    ;; If it is on or past the date.
+	    (when (or (and (> ddays 0) (= diff (- ddays)))
+		      (and (zerop ddays) (= diff 0))
+		      (and (< (+ diff ddays) 0)
+			   (< (abs diff) org-scheduled-past-days)
+			   (and todayp (not org-agenda-only-exact-dates)))
+		      ;; org-is-habit-p uses org-entry-get, which is expansive
+		      ;; so we go extra mile to only call it once
+		      (and todayp
+			   (boundp 'org-habit-show-all-today)
+			   org-habit-show-all-today
+			   (setq did-habit-check-p t)
+			   (setq habitp (and (functionp 'org-is-habit-p)
+					     (org-is-habit-p)))))
+	      (save-excursion
+		(setq donep (member todo-state org-done-keywords))
+		(if (and donep
+			 (or org-agenda-skip-scheduled-if-done
+			     (not (= diff 0))
 			     (and (functionp 'org-is-habit-p)
 				  (org-is-habit-p))))
-	      (setq category (org-get-category)
-		    category-pos (get-text-property (point) 'org-category-position))
-	      (if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown
-			   'repeated-after-deadline)
-		       (org-get-deadline-time (point))
-		       (<= 0 (- d2 (time-to-days (org-get-deadline-time (point))))))
-		  (throw :skip nil))
-	      (if (not (re-search-backward "^\\*+[ \t]+" nil t))
-		  (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)
-			  (and (listp org-agenda-show-inherited-tags)
-			       (memq 'agenda org-agenda-show-inherited-tags))
-			  (and (eq org-agenda-show-inherited-tags t)
-			       (or (eq org-agenda-use-tag-inheritance t)
-				   (memq 'agenda org-agenda-use-tag-inheritance))))
-
-		      tags (org-get-tags-at nil (not inherited-tags)))
-		(setq level (make-string (org-reduced-level (org-outline-level)) ? ))
-		(setq head (buffer-substring
-			    (point)
-			    (progn (skip-chars-forward "^\r\n") (point))))
-		(if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
-		    (setq timestr
-			  (concat (substring s (match-beginning 1)) " "))
-		  (setq timestr 'time))
-		(setq txt (org-agenda-format-item
-			   (if (= diff 0)
-			       (car org-agenda-scheduled-leaders)
-			     (format (nth 1 org-agenda-scheduled-leaders)
-				     (- 1 diff)))
-			   head level category tags
-			   (if (not (= diff 0)) nil timestr)
-			   nil habitp))))
-	    (when txt
-	      (setq face
-		    (cond
-		     ((and (not habitp) pastschedp)
-		      'org-scheduled-previously)
-		     (todayp 'org-scheduled-today)
-		     (t 'org-scheduled))
-		    habitp (and habitp (org-habit-parse-todo)))
-	      (org-add-props txt props
-		'undone-face face
-		'face (if donep 'org-agenda-done face)
-		'org-marker (org-agenda-new-marker pos)
-		'org-hd-marker (org-agenda-new-marker pos1)
-		'type (if pastschedp "past-scheduled" "scheduled")
-		'date (if pastschedp d2 date)
-		'ts-date d2
-		'warntime warntime
-		'level level
-		'priority (if habitp
-			      (org-habit-get-priority habitp)
-			    (+ 94 (- 5 diff) (org-get-priority txt)))
-		'org-category category
-		'category-position category-pos
-		'org-habit-p habitp
-		'todo-state todo-state)
-	      (push txt ee))))))
+		    (setq txt nil)
+		  (setq habitp (if did-habit-check-p habitp
+				 (and (functionp 'org-is-habit-p)
+				      (org-is-habit-p))))
+		  (setq category (org-get-category)
+			category-pos (get-text-property (point) 'org-category-position))
+		  (if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown
+			       'repeated-after-deadline)
+			   (org-get-deadline-time (point))
+			   (<= 0 (- d2 (time-to-days (org-get-deadline-time (point))))))
+		      (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)
+			    (and (listp org-agenda-show-inherited-tags)
+				 (memq 'agenda org-agenda-show-inherited-tags))
+			    (and (eq org-agenda-show-inherited-tags t)
+				 (or (eq org-agenda-use-tag-inheritance t)
+				     (memq 'agenda org-agenda-use-tag-inheritance))))
+
+			tags (org-get-tags-at nil (not inherited-tags)))
+		  (setq level (make-string (org-reduced-level (org-outline-level)) ? ))
+		  (setq head (buffer-substring
+			      (point)
+			      (progn (skip-chars-forward "^\r\n") (point))))
+		  (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+		      (setq timestr
+			    (concat (substring s (match-beginning 1)) " "))
+		    (setq timestr 'time))
+		  (setq txt (org-agenda-format-item
+			     (if (= diff 0)
+				 (car org-agenda-scheduled-leaders)
+			       (format (nth 1 org-agenda-scheduled-leaders)
+				       (- 1 diff)))
+			     head level category tags
+			     (if (not (= diff 0)) nil timestr)
+			     nil habitp)))
+		(when txt
+		  (setq face
+			(cond
+			 ((and (not habitp) pastschedp)
+			  'org-scheduled-previously)
+			 (todayp 'org-scheduled-today)
+			 (t 'org-scheduled))
+			habitp (and habitp (org-habit-parse-todo)))
+		  (org-add-props txt props
+		    'undone-face face
+		    'face (if donep 'org-agenda-done face)
+		    'org-marker (org-agenda-new-marker pos)
+		    'org-hd-marker (org-agenda-new-marker pos1)
+		    'type (if pastschedp "past-scheduled" "scheduled")
+		    'date (if pastschedp d2 date)
+		    'ts-date d2
+		    'warntime warntime
+		    'level level
+		    'priority (if habitp
+				  (org-habit-get-priority habitp)
+				(+ 94 (- 5 diff) (org-get-priority txt)))
+		    'org-category category
+		    'category-position category-pos
+		    'org-habit-p habitp
+		    'todo-state todo-state)
+		  (push txt ee))))))
+	(outline-next-heading)))
     (nreverse ee)))
 
 (defun org-agenda-get-blocks ()
diff --git a/lisp/org.el b/lisp/org.el
index 1a6d028..43858fd 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -878,6 +878,14 @@ Changes become only effective after restarting Emacs."
   :package-version '(Org . "8.0")
   :type 'boolean)
 
+(defconst org-planning-line-re
+  (concat "^[ \t]*"
+	  (regexp-opt
+	   (list org-closed-string org-deadline-string org-scheduled-string)
+	   t))
+  "Matches a line with planning info.
+Matched keyword is in group 1.")
+
 (defconst org-planning-or-clock-line-re (concat "^[ \t]*\\("
 						org-scheduled-string "\\|"
 						org-deadline-string "\\|"
@@ -4662,6 +4670,19 @@ Also put tags into group 4 if tags are present.")
   "List of time keywords.")
 (make-variable-buffer-local 'org-all-time-keywords)
 
+(defconst org-clock-or-timestamp-regexp
+  (concat (format "\\(?:^[ \t]*%s *\\([[<][^]>]+[]>]\\)\\)" org-clock-string)
+	  "\\|"
+	  "\\("
+	  "[[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?[]>]"
+	  "\\|"
+	  "<%%([^\r\n>]*>"
+	  "\\)")
+  "Regexp matching a clock line or a timestamp.
+When matching a clock line, match group 1 contains clock's
+timestamp.  Otherwise, match group 2 contains the regular
+timestamp matched.")
+
 (defconst org-plain-time-of-day-regexp
   (concat
    "\\(\\<[012]?[0-9]"
@@ -15291,44 +15312,39 @@ things up because then unnecessary parsing is avoided."
 		   props))
 	   (when (or (not specific) (string= specific "BLOCKED"))
 	     (push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props))
+
 	   (when (or (not specific)
-		     (member specific
-			     '("SCHEDULED" "DEADLINE" "CLOCK" "CLOSED"
-			       "TIMESTAMP" "TIMESTAMP_IA")))
+		     (member specific '("SCHEDULED" "DEADLINE" "CLOSED")))
+	     (forward-line)
+	     (when (org-looking-at-p org-planning-line-re)
+	       (catch 'match
+		 (let ((end (line-end-position)))
+		   (while (re-search-forward
+			   org-keyword-time-not-clock-regexp end t)
+		     (let ((keyword (match-string 1))
+			   (timestamp (match-string 2)))
+		       (push (cons keyword timestamp) props)
+		       (when (and specific (equal keyword specific))
+			 (throw 'match t))))))
+	       (forward-line)))
+	   (when (or (not specific)
+		     (member specific '("CLOCK" "TIMESTAMP" "TIMESTAMP_IA")))
 	     (catch 'match
-	       (while (and (re-search-forward org-maybe-keyword-time-regexp end t)
+	       (while (and (re-search-forward org-clock-or-timestamp-regexp end t)
 			   (not (text-property-any 0 (length (match-string 0))
 						   'face 'font-lock-comment-face
 						   (match-string 0))))
-		 (setq key (if (match-end 1)
-			       (substring (org-match-string-no-properties 1)
-					  0 -1))
-		       string (if (equal key clockstr)
-				  (org-trim
-				   (buffer-substring-no-properties
-				    (match-beginning 3) (goto-char
-							 (point-at-eol))))
-				(substring (org-match-string-no-properties 3)
-					   1 -1)))
-		 ;; Get the correct property name from the key.  This is
-		 ;; necessary if the user has configured time keywords.
-		 (setq key1 (concat key ":"))
-		 (cond
-		  ((not key)
-		   (setq key
-			 (if (= (char-after (match-beginning 3)) ?\[)
-			     "TIMESTAMP_IA" "TIMESTAMP")))
-		  ((equal key1 org-scheduled-string) (setq key "SCHEDULED"))
-		  ((equal key1 org-deadline-string)  (setq key "DEADLINE"))
-		  ((equal key1 org-closed-string)    (setq key "CLOSED"))
-		  ((equal key1 org-clock-string)     (setq key "CLOCK")))
-		 (if (and specific (equal key specific) (not (equal key "CLOCK")))
-		     (progn
-		       (push (cons key string) props)
-		       ;; no need to search further if match is found
-		       (throw 'match t))
-		   (when (or (equal key "CLOCK") (not (assoc key props)))
-		     (push (cons key string) props)))))))
+		 (let ((key (cond ((match-beginning 1) "CLOCK")
+				  ((= (char-after (match-beginning 2)) ?\[)
+				   "TIMESTAMP_IA")
+				  (t "TIMESTAMP")))
+		       (value (or (match-string 1) (match-string 2))))
+		   (cond
+		    ((and specific (equal key specific) (not (equal key "CLOCK")))
+		     (push (cons key value) props)
+		     (throw 'match t))
+		    ((or (equal key "CLOCK") (not (assoc key props)))
+		     (push (cons key value) props))))))))
 
 	 (when (memq which '(all standard))
 	   ;; Get the standard properties, like :PROP: ...
-- 
2.1.0