org.el: Implement agenda sorting against stats cookies. Code cleanup

* org.el (org-refresh-category-properties): Don't put the
'org-category-position property.
(org-refresh-stats-properties): New function.
(org-agenda-ignore-properties): Rename from
`org-agenda-ignore-drawer-properties', which is now obsolete.
Allow to use 'stats.
(org-agenda-prepare-buffers): Check stats properties.
(org-get-at-bol): Make a defsubst.
(org-get-at-eol): New function.

* org-agenda.el (org-entries-lessp): Sort by statistic
cookies.
(org-search-view, org-agenda-get-todos)
(org-agenda-get-timestamps, org-agenda-get-sexps)
(org-agenda-get-progress, org-agenda-get-deadlines)
(org-agenda-get-scheduled, org-agenda-get-blocks): Don't set
the 'org-category and 'org-category-pos text properties.
'org-category-pos is useless and 'org-category is set through
`org-agenda-format-item'.
(org-agenda-format-item): Remove useless code.
(org-cmp-priority): Delete.
(org-cmp-values): New function to compare text properties
values.
(org-cmp-effort, org-agenda-to-appt): Check against the end of
the line.
(org-agenda-filter-by-category, org-agenda-filter-apply)
(org-agenda-change-all-lines): Use `org-get-at-eol'.
This commit is contained in:
Bastien Guerry 2014-05-23 15:54:50 +02:00
parent d6775b8751
commit 45c4f276f2
2 changed files with 85 additions and 75 deletions

View File

@ -4444,7 +4444,7 @@ in `org-agenda-text-search-extra-files'."
(full-words org-agenda-search-view-force-full-words)
(org-agenda-text-search-extra-files org-agenda-text-search-extra-files)
regexp rtn rtnall files file pos inherited-tags
marker category category-pos level tags c neg re boolean
marker category level tags c neg re boolean
ee txt beg end words regexps+ regexps- hdl-only buffer beg1 str)
(unless (and (not edit-at)
(stringp string)
@ -4610,7 +4610,6 @@ in `org-agenda-text-search-extra-files'."
(setq marker (org-agenda-new-marker (point))
category (org-get-category)
level (make-string (org-reduced-level (org-outline-level)) ? )
category-pos (get-text-property (point) 'org-category-position)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@ -4629,8 +4628,7 @@ in `org-agenda-text-search-extra-files'."
'org-todo-regexp org-todo-regexp
'level level
'org-complex-heading-regexp org-complex-heading-regexp
'priority 1000 'org-category category
'org-category-position category-pos
'priority 1000
'type "search")
(push txt ee)
(goto-char (1- end))))))))))
@ -5356,7 +5354,7 @@ the documentation of `org-diary'."
"|")
"\\|") "\\)"))
(t org-not-done-regexp))))
marker priority category category-pos level tags todo-state ts-date ts-date-type
marker priority category level tags todo-state ts-date ts-date-type
ee txt beg end inherited-tags todo-state-end-pos)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
@ -5403,9 +5401,7 @@ the documentation of `org-diary'."
ts-date-type ""))
(t (setq ts-date-type "")))
(when ts (ignore-errors (org-time-string-to-absolute ts)))))
category-pos (get-text-property (point) 'org-category-position)
txt (org-trim
(buffer-substring (match-beginning 2) (match-end 0)))
txt (org-trim (buffer-substring (match-beginning 2) (match-end 0)))
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@ -5419,10 +5415,9 @@ the documentation of `org-diary'."
priority (1+ (org-get-priority txt)))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
'priority priority 'org-category category
'priority priority
'level level
'ts-date ts-date
'org-category-position category-pos
'type (concat "todo" ts-date-type) 'todo-state todo-state)
(push txt ee)
(if org-agenda-todo-list-sublevels
@ -5541,7 +5536,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
"\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[hdwmy]>\\)"
"\\|\\(<%%\\(([^>\n]+)\\)>\\)"))
marker hdmarker deadlinep scheduledp clockp closedp inactivep
donep tmp priority category category-pos level ee txt timestr tags
donep tmp priority category level ee txt timestr tags
b0 b3 e3 head todo-state end-of-match show-all warntime habitp
inherited-tags ts-date)
(goto-char (point-min))
@ -5585,8 +5580,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
;; substring should only run to end of time stamp
(setq timestr (substring timestr 0 (match-end 0))))
(setq marker (org-agenda-new-marker b0)
category (org-get-category b0)
category-pos (get-text-property b0 'org-category-position))
category (org-get-category b0))
(save-excursion
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
@ -5613,11 +5607,10 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(setq priority (org-get-priority txt))
(org-add-props txt props 'priority priority
'org-marker marker 'org-hd-marker hdmarker
'org-category category 'date date
'date date
'level level
'ts-date
(ignore-errors (org-time-string-to-absolute timestr))
'org-category-position category-pos
'todo-state todo-state
'warntime warntime
'type "timestamp")
@ -5636,7 +5629,7 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
(regexp "^&?%%(")
marker category extra category-pos level ee txt tags entry
marker category extra level ee txt tags entry
result beg b sexp sexp-entry todo-state warntime inherited-tags)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
@ -5655,7 +5648,6 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(setq marker (org-agenda-new-marker beg)
level (make-string (org-reduced-level (org-outline-level)) ? )
category (org-get-category beg)
category-pos (get-text-property beg 'org-category-position)
inherited-tags
(or (eq org-agenda-show-inherited-tags 'always)
(and (listp org-agenda-show-inherited-tags)
@ -5680,9 +5672,8 @@ This function is invoked if `org-agenda-todo-ignore-deadlines',
(setq txt "SEXP entry returned empty string"))
(setq txt (org-agenda-format-item extra txt level category tags 'time))
(org-add-props txt props 'org-marker marker
'org-category category 'date date 'todo-state todo-state
'org-category-position category-pos 'tags tags
'level level
'date date 'todo-state todo-state
'tags tags 'level level
'type "sexp" 'warntime warntime)
(push txt ee)))))
(nreverse ee)))
@ -5792,7 +5783,7 @@ please use `org-class' instead."
(list 0 0 0 (nth 1 date) (car date) (nth 2 date))))
1 11))))
(org-agenda-search-headline-for-time nil)
marker hdmarker priority category category-pos level tags closedp
marker hdmarker priority category level tags closedp
statep clockp state ee txt extra timestr rest clocked inherited-tags)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
@ -5804,7 +5795,6 @@ please use `org-class' instead."
clockp (not (or closedp statep))
state (and statep (match-string 2))
category (org-get-category (match-beginning 0))
category-pos (get-text-property (match-beginning 0) 'org-category-position)
timestr (buffer-substring (match-beginning 0) (point-at-eol)))
(when (string-match "\\]" timestr)
;; substring should only run to end of time stamp
@ -5856,9 +5846,7 @@ please use `org-class' instead."
(setq priority 100000)
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done
'priority priority 'org-category category
'org-category-position category-pos
'level level
'priority priority 'level level
'type "closed" 'date date
'undone-face 'org-warning 'done-face 'org-agenda-done)
(push txt ee))
@ -6004,7 +5992,7 @@ specification like [h]h:mm."
(dl0 (car org-agenda-deadline-leaders))
(dl1 (nth 1 org-agenda-deadline-leaders))
(dl2 (or (nth 2 org-agenda-deadline-leaders) dl1))
d2 diff dfrac wdays pos pos1 category category-pos level
d2 diff dfrac wdays pos pos1 category level
tags suppress-prewarning ee txt head face s todo-state
show-all upcomingp donep timestr warntime inherited-tags ts-date)
(goto-char (point-min))
@ -6064,8 +6052,7 @@ specification like [h]h:mm."
(not (= diff 0))))
(setq txt nil)
(setq category (org-get-category)
warntime (get-text-property (point) 'org-appt-warntime)
category-pos (get-text-property (point) 'org-category-position))
warntime (get-text-property (point) 'org-appt-warntime))
(if (not (re-search-backward "^\\*+[ \t]+" nil t))
(throw :skip nil)
(goto-char (match-end 0))
@ -6110,8 +6097,6 @@ specification like [h]h:mm."
'org-hd-marker (org-agenda-new-marker pos1)
'priority (+ (- diff)
(org-get-priority txt))
'org-category category
'org-category-position category-pos
'todo-state todo-state
'type (if upcomingp "upcoming-deadline" "deadline")
'date (if upcomingp date d2)
@ -6151,7 +6136,7 @@ an hour specification like [h]h:mm."
0 'org-hd-marker a))
(cons (marker-position mm) a)))
deadline-results))
d2 diff pos pos1 category category-pos level tags donep
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)
@ -6230,8 +6215,7 @@ an hour specification like [h]h:mm."
(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))
(setq category (org-get-category))
(if (and (eq org-agenda-skip-scheduled-if-deadline-is-shown
'repeated-after-deadline)
(org-get-deadline-time (point))
@ -6299,8 +6283,6 @@ an hour specification like [h]h:mm."
'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))))))
@ -6318,7 +6300,7 @@ an hour specification like [h]h:mm."
(abbreviate-file-name buffer-file-name))))
(regexp org-tr-regexp)
(d0 (calendar-absolute-from-gregorian date))
marker hdmarker ee txt d1 d2 s1 s2 category category-pos
marker hdmarker ee txt d1 d2 s1 s2 category
level todo-state tags pos head donep inherited-tags)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
@ -6339,9 +6321,8 @@ an hour specification like [h]h:mm."
(setq donep (member todo-state org-done-keywords))
(if (and donep org-agenda-skip-timestamp-if-done)
(throw :skip t))
(setq marker (org-agenda-new-marker (point)))
(setq category (org-get-category)
category-pos (get-text-property (point) 'org-category-position))
(setq marker (org-agenda-new-marker (point))
category (org-get-category))
(if (not (re-search-backward org-outline-regexp-bol nil t))
(throw :skip nil)
(goto-char (match-beginning 0))
@ -6383,8 +6364,7 @@ an hour specification like [h]h:mm."
'type "block" 'date date
'level level
'todo-state todo-state
'priority (org-get-priority txt) 'org-category category
'org-category-position category-pos)
'priority (org-get-priority txt))
(push txt ee))))
(goto-char pos)))
;; Sort the entries by expiration date.
@ -6455,9 +6435,6 @@ Any match of REMOVE-RE will be removed from TXT."
org-agenda-hide-tags-regexp))
(let* ((category (or category
(if (stringp org-category)
org-category
(and org-category (symbol-name org-category)))
(if buffer-file-name
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))
@ -6474,7 +6451,7 @@ Any match of REMOVE-RE will be removed from TXT."
(and org-agenda-search-headline-for-time txt))))
(time-of-day (and dotime (org-get-time-of-day ts)))
stamp plain s0 s1 s2 rtn srp l
duration thecategory breadcrumbs)
duration breadcrumbs)
(and (derived-mode-p 'org-mode) buffer-file-name
(add-to-list 'org-agenda-contributing-files buffer-file-name))
(when (and dotime time-of-day)
@ -6561,7 +6538,6 @@ Any match of REMOVE-RE will be removed from TXT."
(t ""))
extra (or (and (not habitp) extra) "")
category (if (symbolp category) (symbol-name category) category)
thecategory (copy-sequence category)
level (or level ""))
(if (string-match org-bracket-link-regexp category)
(progn
@ -6582,7 +6558,7 @@ Any match of REMOVE-RE will be removed from TXT."
;; And finally add the text properties
(remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn)
(org-add-props rtn nil
'org-category (if thecategory (downcase thecategory) category)
'org-category category
'tags (mapcar 'org-downcase-keep-props tags)
'org-highest-priority org-highest-priority
'org-lowest-priority org-lowest-priority
@ -6906,25 +6882,25 @@ The optional argument TYPE tells the agenda type."
(substring x (match-end 3)))))))
x)))
(defsubst org-cmp-priority (a b)
"Compare the priorities of string A and B."
(let ((pa (or (get-text-property 1 'priority a) 0))
(pb (or (get-text-property 1 'priority b) 0)))
(defsubst org-cmp-values (a b property)
"Compare the numeric value of text PROPERTY for string A and B."
(let ((pa (or (get-text-property (1- (length a)) property a) 0))
(pb (or (get-text-property (1- (length b)) property b) 0)))
(cond ((> pa pb) +1)
((< pa pb) -1))))
(defsubst org-cmp-effort (a b)
"Compare the effort values of string A and B."
(let* ((def (if org-sort-agenda-noeffort-is-high 32767 -1))
(ea (or (get-text-property 1 'effort-minutes a) def))
(eb (or (get-text-property 1 'effort-minutes b) def)))
(ea (or (get-text-property (1- (length a)) 'effort-minutes a) def))
(eb (or (get-text-property (1- (length b)) 'effort-minutes b) def)))
(cond ((> ea eb) +1)
((< ea eb) -1))))
(defsubst org-cmp-category (a b)
"Compare the string values of categories of strings A and B."
(let ((ca (or (get-text-property 1 'org-category a) ""))
(cb (or (get-text-property 1 'org-category b) "")))
(let ((ca (or (get-text-property (1- (length a)) 'org-category a) ""))
(cb (or (get-text-property (1- (length b)) 'org-category b) "")))
(cond ((string-lessp ca cb) -1)
((string-lessp cb ca) +1))))
@ -7032,8 +7008,11 @@ their type."
(time-up (and (org-em 'time-up 'time-down ss)
(org-cmp-time a b)))
(time-down (if time-up (- time-up) nil))
(stats-up (and (org-em 'stats-up 'stats-down ss)
(org-cmp-values a b 'org-stats)))
(stats-down (if stats-up (- stats-up) nil))
(priority-up (and (org-em 'priority-up 'priority-down ss)
(org-cmp-priority a b)))
(org-cmp-values a b 'priority)))
(priority-down (if priority-up (- priority-up) nil))
(effort-up (and (org-em 'effort-up 'effort-down ss)
(org-cmp-effort a b)))
@ -7316,7 +7295,7 @@ The category is that of the current line."
(if (and org-agenda-filtered-by-category
org-agenda-category-filter)
(org-agenda-filter-show-all-cat)
(let ((cat (org-no-properties (get-text-property (point) 'org-category))))
(let ((cat (org-no-properties (org-get-at-eol 'org-category 1))))
(cond
((and cat strip)
(org-agenda-filter-apply
@ -7624,7 +7603,7 @@ When NO-OPERATOR is non-nil, do not add the + operator to returned tags."
(mapcar (lambda (f)
(org-agenda-filter-expand-tags (list f) t))
(org-get-at-bol 'tags)))
cat (get-text-property (point) 'org-category)
cat (org-get-at-eol 'org-category 1)
txt (get-text-property (point) 'txt))
(if (not (eval org-agenda-filter-form))
(org-agenda-filter-hide-line type))
@ -8838,7 +8817,7 @@ If FORCE-TAGS is non nil, the car of it returns the new tags."
(equal m hdmarker))
(setq props (text-properties-at (point))
dotime (org-get-at-bol 'dotime)
cat (org-get-at-bol 'org-category)
cat (org-get-at-eol 'org-category 1)
level (org-get-at-bol 'level)
tags thetags
new
@ -10069,7 +10048,7 @@ to override `appt-message-warning-time'."
(replace-regexp-in-string
org-bracket-link-regexp "\\3"
(or (get-text-property 1 'txt x) ""))))
(cat (get-text-property 1 'org-category x))
(cat (get-text-property (1- (length x)) 'org-category x))
(tod (get-text-property 1 'time-of-day x))
(ok (or (null filter)
(and (stringp filter) (string-match filter evt))

View File

@ -9379,8 +9379,6 @@ call CMD."
(eval `(let ,binds
(call-interactively (quote ,cmd))))))
;;;; Archiving
(defun org-get-category (&optional pos force-refresh)
"Get the category applying to position POS."
(save-match-data
@ -9390,6 +9388,8 @@ call CMD."
(progn (org-refresh-category-properties)
(get-text-property pos 'org-category))))))
;;; Refresh properties
(defun org-refresh-category-properties ()
"Refresh category text properties in the buffer."
(let ((case-fold-search t)
@ -9419,9 +9419,28 @@ call CMD."
(org-back-to-heading t)
(setq beg (point) end (org-end-of-subtree t t)))
(put-text-property beg end 'org-category cat)
(put-text-property beg end 'org-category-position beg)
(goto-char pos)))))))
(defun org-refresh-stats-properties ()
"Refresh stats text properties in the buffer."
(let (stats)
(org-with-silent-modifications
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(while (re-search-forward
(concat org-outline-regexp-bol ".*"
"\\(?:\\[\\([0-9]+\\)%\\|\\([0-9]+\\)/\\([0-9]+\\)\\]\\)")
nil t)
(setq stats (if (match-string 2)
(/ (* (string-to-number (match-string 2)) 100)
(string-to-number (match-string 3)))
(string-to-number (match-string 1))))
(org-back-to-heading t)
(put-text-property (point) (progn (org-end-of-subtree t t) (point))
'org-stats stats)))))))
(defun org-refresh-properties (dprop tprop)
"Refresh buffer text properties.
DPROP is the drawer property and TPROP is the corresponding text
@ -17868,19 +17887,25 @@ is not set, the tables are not re-aligned, etc."
:version "24.3"
:group 'org-agenda)
(defcustom org-agenda-ignore-drawer-properties nil
(define-obsolete-variable-alias
'org-agenda-ignore-drawer-properties
'org-agenda-ignore-properties "24.5")
(defcustom org-agenda-ignore-properties nil
"Avoid updating text properties when building the agenda.
Properties are used to prepare buffers for effort estimates, appointments,
and subtree-local categories.
If you don't use these in the agenda, you can add them to this list and
agenda building will be a bit faster.
Properties are used to prepare buffers for effort estimates,
appointments, statistics and subtree-local categories.
If you don't use these in the agenda, you can add them to this
list and agenda building will be a bit faster.
The value is a list, with zero or more of the symbols `effort', `appt',
or `category'."
`stats' or `category'."
:type '(set :greedy t
(const effort)
(const appt)
(const stats)
(const category))
:version "24.3"
:version "24.5"
:package-version '(Org . "8.3")
:group 'org-agenda)
(defun org-duration-string-to-minutes (s &optional output-to-string)
@ -18246,11 +18271,13 @@ When a buffer is unmodified, it is just killed. When modified, it is saved
;; this is only run for setting agenda tags from setup
;; file
(org-set-regexps-and-options)))
(or (memq 'category org-agenda-ignore-drawer-properties)
(or (memq 'category org-agenda-ignore-properties)
(org-refresh-category-properties))
(or (memq 'effort org-agenda-ignore-drawer-properties)
(or (memq 'stats org-agenda-ignore-properties)
(org-refresh-stats-properties))
(or (memq 'effort org-agenda-ignore-properties)
(org-refresh-properties org-effort-property 'org-effort))
(or (memq 'appt org-agenda-ignore-drawer-properties)
(or (memq 'appt org-agenda-ignore-properties)
(org-refresh-properties "APPT_WARNTIME" 'org-appt-warntime))
(setq org-todo-keywords-for-agenda
(append org-todo-keywords-for-agenda org-todo-keywords-1))
@ -21435,10 +21462,14 @@ With prefix arg UNCOMPILED, load the uncompiled versions."
;;; Generally useful functions
(defun org-get-at-bol (property)
"Get text property PROPERTY at beginning of line."
(defsubst org-get-at-bol (property)
"Get text property PROPERTY at the beginning of line."
(get-text-property (point-at-bol) property))
(defsubst org-get-at-eol (property n)
"Get text property PROPERTY at the end of line less N characters."
(get-text-property (- (point-at-eol) n) property))
(defun org-find-text-property-in-string (prop s)
"Return the first non-nil value of property PROP in string S."
(or (get-text-property 0 prop s)