summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-14 10:17:14 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-17 22:49:19 +0100
commit279902ca4da4fe5f0ceff801a3aab51b942b42b7 (patch)
treed5e7bae0377c1337a797e5ffaf40f8ce698cedac
parent3196b1434289c9427704f0eccc074f7d5901715a (diff)
downloadorg-mode-279902ca4da4fe5f0ceff801a3aab51b942b42b7.tar.gz
org-colview: Fix column width computation
* lisp/org-colview.el (org-columns-current-widths): Remove variable. (org-columns--value): Remove function. (org-columns--displayed-value): New function. (org-columns--collect-values): New function. (org-columns-display-here): Rename function to... (org-columns--display-here): ... this. First argument is now mandatory. (org-columns-display-here-title): Rename function to... (org-columns--display-here-title): ... this. (org-columns-autowidth-alist): Rename function to... (org-columns--autowidth-alist): ... this. Remove one argument. (org-columns-edit-value): (org-columns-next-allowed-value): Always refresh all columns, not only the current one. Otherwise, the current column may end up with a different width than the others. (org-columns): (org-dblock-write:columnview): (org-agenda-columns): (org-agenda-colview-summarize): Apply changes above. Columns width is now computed according to displayed values, not real ones.
-rw-r--r--lisp/org-colview.el527
1 files changed, 237 insertions, 290 deletions
diff --git a/lisp/org-colview.el b/lisp/org-colview.el
index 1c1fc6a..6e1956b 100644
--- a/lisp/org-colview.el
+++ b/lisp/org-colview.el
@@ -35,6 +35,11 @@
(declare-function org-agenda-do-context-action "org-agenda" ())
(declare-function org-clock-sum-today "org-clock" (&optional headline-filter))
+(defvar org-agenda-columns-add-appointments-to-effort-sum)
+(defvar org-agenda-columns-compute-summary-properties)
+(defvar org-agenda-columns-show-summaries)
+(defvar org-agenda-view-columns-initially)
+
;;; Configuration
(defcustom org-columns-modify-value-for-display-function nil
@@ -62,8 +67,6 @@ or nil if the normal value should be used."
(defvar-local org-columns-current-fmt-compiled nil
"Local variable, holds the currently active column format.
This is the compiled version of the format.")
-(defvar-local org-columns-current-widths nil
- "Loval variable, holds the currently widths of fields.")
(defvar-local org-columns-current-maxwidths nil
"Loval variable, holds the currently active maximum column widths.")
(defvar org-columns-begin-marker (make-marker)
@@ -156,10 +159,82 @@ This is the compiled version of the format.")
"--"
["Quit" org-columns-quit t]))
-(defun org-columns--value (property pos)
- "Return value for PROPERTY at buffer position POS."
- (or (cdr (assoc-string property (get-text-property pos 'org-summaries) t))
- (org-entry-get pos property 'selective t)))
+(defun org-columns--displayed-value (property value)
+ "Return displayed value for PROPERTY in current entry.
+
+VALUE is the real value of the property, as a string.
+
+This function assumes `org-columns-current-fmt-compiled' is
+initialized."
+ (pcase (assoc-string property org-columns-current-fmt-compiled t)
+ (`(,_ ,_ ,_ ,_ ,fmt ,printf ,_ ,calc)
+ (cond
+ ((and (functionp org-columns-modify-value-for-display-function)
+ (funcall
+ org-columns-modify-value-for-display-function
+ (nth 1 (assoc-string property org-columns-current-fmt-compiled t))
+ value)))
+ ((equal (upcase property) "ITEM")
+ (concat (make-string (1- (org-current-level))
+ (if org-hide-leading-stars ?\s ?*))
+ "* "
+ (org-columns-compact-links value)))
+ (printf (org-columns-number-to-string
+ (org-columns-string-to-number value fmt) fmt printf))
+ ((and (functionp calc)
+ (not (string= value ""))
+ (not (get-text-property 0 'org-computed value)))
+ (org-columns-number-to-string
+ (funcall calc (org-columns-string-to-number value fmt)) fmt))
+ (value)))))
+
+(defun org-columns--collect-values (&optional agenda)
+ "Collect values for columns on the current line.
+
+When optional argument AGENDA is non-nil, assume the value is
+meant for the agenda, i.e., caller is `org-agenda-columns'.
+
+Return a list of triplets (PROPERTY VALUE DISPLAYED) suitable for
+`org-columns--display-here'.
+
+This function assumes `org-columns-current-fmt-compiled' is
+initialized."
+ (mapcar
+ (lambda (spec)
+ (let* ((p (car spec))
+ (v (or (cdr (assoc-string
+ p (get-text-property (point) 'org-summaries) t))
+ (org-entry-get (point) p 'selective t)
+ (and agenda
+ ;; Effort property is not defined. Try to use
+ ;; appointment duration.
+ org-agenda-columns-add-appointments-to-effort-sum
+ (string= (upcase p) (upcase org-effort-property))
+ (get-text-property (point) 'duration)
+ (org-propertize
+ (org-minutes-to-clocksum-string
+ (get-text-property (point) 'duration))
+ 'face 'org-warning))
+ "")))
+ (list p v (org-columns--displayed-value p v))))
+ org-columns-current-fmt-compiled))
+
+(defun org-columns--autowidth-alist (cache)
+ "Derive the maximum column widths from the format and the cache.
+Return an alist (PROPERTY . WIDTH), with PROPERTY as a string and
+WIDTH as an integer greater than 0."
+ (mapcar
+ (lambda (spec)
+ (pcase spec
+ (`(,property ,name ,width . ,_)
+ (if width (cons property width)
+ ;; No width is specified in the columns format. Compute it
+ ;; by checking all possible values for PROPERTY.
+ (let ((width (length name)))
+ (dolist (entry cache (cons property width))
+ (let ((value (nth 2 (assoc-string property (cdr entry) t))))
+ (setq width (max (length value) width)))))))))
+ org-columns-current-fmt-compiled))
(defun org-columns-new-overlay (beg end &optional string face)
"Create a new column overlay and add it to the list."
@@ -169,9 +244,11 @@ This is the compiled version of the format.")
(push ov org-columns-overlays)
ov))
-(defun org-columns-display-here (&optional props dateline)
- "Overlay the current line with column display."
- (interactive)
+(defun org-columns--display-here (columns &optional dateline)
+ "Overlay the current line with column display.
+COLUMNS is an alist (PROPERTY VALUE DISPLAYED). Optional
+argument DATELINE is non-nil when the face used should be
+`org-agenda-column-dateline'."
(save-excursion
(beginning-of-line)
(let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)")
@@ -184,14 +261,7 @@ This is the compiled version of the format.")
(font (list :height (face-attribute 'default :height)
:family (face-attribute 'default :family)))
(face (list color font 'org-column ref-face))
- (face1 (list color font 'org-agenda-column-dateline ref-face))
- (pom (and (eq major-mode 'org-agenda-mode)
- (or (org-get-at-bol 'org-hd-marker)
- (org-get-at-bol 'org-marker))))
- (props (cond (props)
- ((eq major-mode 'org-agenda-mode)
- (and pom (org-entry-properties pom)))
- (t (org-entry-properties)))))
+ (face1 (list color font 'org-agenda-column-dateline ref-face)))
;; Each column is an overlay on top of a character. So there has
;; to be at least as many characters available on the line as
;; columns to display.
@@ -202,64 +272,43 @@ This is the compiled version of the format.")
(end-of-line)
(let ((inhibit-read-only t))
(insert (make-string (- columns chars) ?\s))))))
- ;; Walk the format. Create and install the overlay for the
+ ;; Display columns. Create and install the overlay for the
;; current column on the next character.
- (dolist (column org-columns-current-fmt-compiled)
- (let* ((property (car column))
- (title (nth 1 column))
- (ass (assoc-string property props t))
- (width
- (or
- (cdr (assoc-string property org-columns-current-maxwidths t))
- (nth 2 column)
- (length property)))
- (f (format "%%-%d.%ds | " width width))
- (fm (nth 4 column))
- (fc (nth 5 column))
- (calc (nth 7 column))
- (val (or (cdr ass) ""))
- (modval
- (cond
- ((functionp org-columns-modify-value-for-display-function)
- (funcall org-columns-modify-value-for-display-function
- title val))
- ((equal property "ITEM") (org-columns-compact-links val))
- (fc (org-columns-number-to-string
- (org-columns-string-to-number val fm) fm fc))
- ((and calc (functionp calc)
- (not (string= val ""))
- (not (get-text-property 0 'org-computed val)))
- (org-columns-number-to-string
- (funcall calc (org-columns-string-to-number val fm)) fm))))
- (string
- (format f
- (let ((v (org-columns-add-ellipses
- (or modval val) width)))
- (cond
- ((equal property "PRIORITY")
- (propertize v 'face (org-get-priority-face val)))
- ((equal property "TAGS")
- (if (not org-tags-special-faces-re)
- (propertize v 'face 'org-tag)
- (replace-regexp-in-string
- org-tags-special-faces-re
- (lambda (m)
- (propertize m 'face (org-get-tag-face m)))
- v nil nil 1)))
- ((equal property "TODO")
- (propertize v 'face (org-get-todo-face val)))
- (t v)))))
- (ov (org-columns-new-overlay
- (point) (1+ (point)) string (if dateline face1 face))))
- (overlay-put ov 'keymap org-columns-map)
- (overlay-put ov 'org-columns-key property)
- (overlay-put ov 'org-columns-value (cdr ass))
- (overlay-put ov 'org-columns-value-modified modval)
- (overlay-put ov 'org-columns-pom pom)
- (overlay-put ov 'org-columns-format f)
- (overlay-put ov 'line-prefix "")
- (overlay-put ov 'wrap-prefix "")
- (forward-char)))
+ (dolist (column columns)
+ (pcase column
+ (`(,property ,original ,value)
+ (let* ((width
+ (cdr
+ (assoc-string property org-columns-current-maxwidths t)))
+ (fmt (format "%%-%d.%ds | " width width))
+ (text
+ (format
+ fmt
+ (let ((v (org-columns-add-ellipses value width)))
+ (pcase (upcase property)
+ ("PRIORITY"
+ (propertize v 'face (org-get-priority-face original)))
+ ("TAGS"
+ (if (not org-tags-special-faces-re)
+ (propertize v 'face 'org-tag)
+ (replace-regexp-in-string
+ org-tags-special-faces-re
+ (lambda (m)
+ (propertize m 'face (org-get-tag-face m)))
+ v nil nil 1)))
+ ("TODO"
+ (propertize v 'face (org-get-todo-face original)))
+ (_ v)))))
+ (ov (org-columns-new-overlay
+ (point) (1+ (point)) text (if dateline face1 face))))
+ (overlay-put ov 'keymap org-columns-map)
+ (overlay-put ov 'org-columns-key property)
+ (overlay-put ov 'org-columns-value original)
+ (overlay-put ov 'org-columns-value-modified value)
+ (overlay-put ov 'org-columns-format fmt)
+ (overlay-put ov 'line-prefix "")
+ (overlay-put ov 'wrap-prefix "")
+ (forward-char)))))
;; Make the rest of the line disappear.
(let ((ov (org-columns-new-overlay (point) (line-end-position))))
(overlay-put ov 'invisible t)
@@ -303,33 +352,23 @@ for the duration of the command.")
(defvar header-line-format)
(defvar org-columns-previous-hscroll 0)
-(defun org-columns-display-here-title ()
+(defun org-columns--display-here-title ()
"Overlay the newline before the current line with the table title."
(interactive)
- (let ((fmt org-columns-current-fmt-compiled)
- string (title "")
- property width f column str widths)
- (while (setq column (pop fmt))
- (setq property (car column)
- str (or (nth 1 column) property)
- width (or (cdr (assoc-string property
- org-columns-current-maxwidths
- t))
- (nth 2 column)
- (length str))
- widths (push width widths)
- f (format "%%-%d.%ds | " width width)
- string (format f str)
- title (concat title string)))
- (setq title (concat
- (org-add-props " " nil 'display '(space :align-to 0))
- ;;(org-add-props title nil 'face '(:weight bold :underline t :inherit default))))
- (org-add-props title nil 'face 'org-column-title)))
+ (let ((title ""))
+ (dolist (column org-columns-current-fmt-compiled)
+ (pcase column
+ (`(,property ,name . ,_)
+ (let* ((width
+ (cdr (assoc-string property org-columns-current-maxwidths t)))
+ (fmt (format "%%-%d.%ds | " width width)))
+ (setq title (concat title (format fmt (or name property))))))))
+ (setq title
+ (concat (org-add-props " " nil 'display '(space :align-to 0))
+ (org-add-props title nil 'face 'org-column-title)))
(setq-local org-previous-header-line-format header-line-format)
- (setq-local org-columns-current-widths (nreverse widths))
(setq org-columns-full-header-line-format title)
(setq org-columns-previous-hscroll -1)
- ; (org-columns-hscoll-title)
(org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local)))
(defun org-columns-hscoll-title ()
@@ -432,13 +471,6 @@ Where possible, use the standard interface for changing this line."
(bol (point-at-bol)) (eol (point-at-eol))
(pom (or (get-text-property bol 'org-hd-marker)
(point))) ; keep despite of compiler waring
- (line-overlays
- (delq nil (mapcar (lambda (x)
- (and (eq (overlay-buffer x) (current-buffer))
- (>= (overlay-start x) bol)
- (<= (overlay-start x) eol)
- x))
- org-columns-overlays)))
(org-columns-time (time-to-number-of-days (current-time)))
nval eval allowed)
(cond
@@ -496,17 +528,9 @@ Where possible, use the standard interface for changing this line."
(org-with-silent-modifications
(remove-text-properties
(max (point-min) (1- bol)) eol '(read-only t)))
- (unwind-protect
- (progn
- (setq org-columns-overlays
- (org-delete-all line-overlays org-columns-overlays))
- (mapc 'delete-overlay line-overlays)
- (org-columns-eval eval))
- (org-columns-display-here)))
+ (org-columns-eval eval))
(org-move-to-column col)
- (if (and (derived-mode-p 'org-mode)
- (nth 3 (assoc-string key org-columns-current-fmt-compiled t)))
- (org-columns-update key)))))))
+ (org-columns-update key))))))
(defun org-edit-headline () ; FIXME: this is not columns specific. Make interactive????? Use from agenda????
"Edit the current headline, the part without TODO keyword, TAGS."
@@ -575,13 +599,6 @@ an integer, select that value."
(bol (point-at-bol)) (eol (point-at-eol))
(pom (or (get-text-property bol 'org-hd-marker)
(point))) ; keep despite of compiler waring
- (line-overlays
- (delq nil (mapcar (lambda (x)
- (and (eq (overlay-buffer x) (current-buffer))
- (>= (overlay-start x) bol)
- (<= (overlay-start x) eol)
- x))
- org-columns-overlays)))
(allowed (or (org-property-get-allowed-values pom key)
(and (memq
(nth 4 (assoc-string key
@@ -627,16 +644,9 @@ an integer, select that value."
(t
(let ((inhibit-read-only t))
(remove-text-properties (max (1- bol) (point-min)) eol '(read-only t))
- (unwind-protect
- (progn
- (setq org-columns-overlays
- (org-delete-all line-overlays org-columns-overlays))
- (mapc 'delete-overlay line-overlays)
- (org-columns-eval `(org-entry-put ,pom ,key ,nval)))
- (org-columns-display-here)))
+ (org-columns-eval `(org-entry-put ,pom ,key ,nval)))
(org-move-to-column col)
- (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t))
- (org-columns-update key))))))
+ (org-columns-update key)))))
(defun org-colview-construct-allowed-dates (s)
"Construct a list of three dates around the date in S.
@@ -708,34 +718,20 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(narrow-to-region
(point)
(if (org-at-heading-p) (org-end-of-subtree t t) (point-max)))
- (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled)
+ (when (assoc-string "CLOCKSUM" org-columns-current-fmt-compiled t)
(org-clock-sum))
- (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled)
+ (when (assoc-string "CLOCKSUM_T" org-columns-current-fmt-compiled t)
(org-clock-sum-today))
- (let* ((column-names (mapcar #'car org-columns-current-fmt-compiled))
- (cache
- (org-map-entries
- (lambda ()
- (cons (point)
- (mapcar
- (lambda (p)
- (cons p
- (let ((v (org-columns--value p (point))))
- (if (not (equal "ITEM" p)) v
- (concat (make-string
- (1- (org-current-level))
- (if org-hide-leading-stars
- ?\s ?*))
- "* "
- v)))))
- column-names)))
- nil nil (and org-columns-skip-archived-trees 'archive))))
+ (let ((cache
+ ;; Collect contents of columns ahead of time so as to
+ ;; compute their maximum width.
+ (org-map-entries
+ (lambda () (cons (point) (org-columns--collect-values)))
+ nil nil (and org-columns-skip-archived-trees 'archive))))
(when cache
(setq-local org-columns-current-maxwidths
- (org-columns-get-autowidth-alist
- org-columns-current-fmt
- cache))
- (org-columns-display-here-title)
+ (org-columns--autowidth-alist cache))
+ (org-columns--display-here-title)
(when (setq-local org-columns-flyspell-was-active
(org-bound-and-true-p flyspell-mode))
(flyspell-mode 0))
@@ -743,9 +739,9 @@ When COLUMNS-FMT-STRING is non-nil, use it as the column format."
(setq-local org-colview-initial-truncate-line-value
truncate-lines))
(setq truncate-lines t)
- (dolist (x cache)
- (goto-char (car x))
- (org-columns-display-here (cdr x))))))))
+ (dolist (entry cache)
+ (goto-char (car entry))
+ (org-columns--display-here (cdr entry))))))))
(defvar org-columns-compile-map
'(("none" none +)
@@ -909,24 +905,6 @@ display, or in the #+COLUMNS line of the current buffer."
(insert-before-markers "#+COLUMNS: " fmt "\n")))
(setq-local org-columns-default-format fmt))))))
-(defun org-columns-get-autowidth-alist (s cache)
- "Derive the maximum column widths from the format and the cache."
- (let ((start 0) rtn)
- (while (string-match (org-re "%\\([[:alpha:]][[:alnum:]_-]*\\)") s start)
- (push (cons (match-string 1 s) 1) rtn)
- (setq start (match-end 0)))
- (mapc (lambda (x)
- (setcdr x
- (apply #'max
- (let ((prop (car x)))
- (mapcar
- (lambda (y)
- (length (or (cdr (assoc-string prop (cdr y) t))
- " ")))
- cache)))))
- rtn)
- rtn))
-
(defun org-columns-compute-all ()
"Compute all columns that have operators defined."
(org-with-silent-modifications
@@ -1346,7 +1324,7 @@ PARAMS is a property list of parameters:
(insert (org-listtable-to-string tbl))
(when (plist-get params :width)
(insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x)))
- org-columns-current-widths "|")))
+ org-columns-current-maxwidths "|")))
(while (setq line (pop content-lines))
(when (string-match "^#" line)
(insert "\n" line)
@@ -1387,11 +1365,6 @@ and tailing newline characters."
;;; Column view in the agenda
-(defvar org-agenda-view-columns-initially)
-(defvar org-agenda-columns-show-summaries) ; defined in org-agenda.el
-(defvar org-agenda-columns-compute-summary-properties); defined in org-agenda.el
-(defvar org-agenda-columns-add-appointments-to-effort-sum); as well
-
;;;###autoload
(defun org-agenda-columns ()
"Turn on or update column view in the agenda."
@@ -1424,127 +1397,101 @@ and tailing newline characters."
;; Collect properties for each headline in current view.
(goto-char (point-min))
(let (cache)
- (let ((names (mapcar #'car org-columns-current-fmt-compiled)) m)
- (while (not (eobp))
- (when (setq m (or (org-get-at-bol 'org-hd-marker)
- (org-get-at-bol 'org-marker)))
- (push
- (cons
- (line-beginning-position)
- (org-with-point-at m
- (mapcar
- (lambda (name)
- (let ((value (org-columns--value name (point))))
- (cons
- name
- (cond
- ((and org-agenda-columns-add-appointments-to-effort-sum
- (not value)
- (eq (compare-strings name nil nil
- org-effort-property nil nil
- t)
- t)
- ;; Effort property is not defined. Try ;
- ;; to use appointment duration. ;
- (get-text-property (point) 'duration))
- (org-propertize
- (org-minutes-to-clocksum-string
- (get-text-property (point) 'duration))
- 'face 'org-warning))
- ((equal "ITEM" name)
- (concat (make-string (org-current-level) ?*)
- " "
- value))
- (t value)))))
- names)))
- cache))
- (forward-line)))
+ (while (not (eobp))
+ (let ((m (or (org-get-at-bol 'org-hd-marker)
+ (org-get-at-bol 'org-marker))))
+ (when m
+ (push (cons (line-beginning-position)
+ (org-with-point-at m
+ (org-columns--collect-values 'agenda)))
+ cache)))
+ (forward-line))
(when cache
(setq-local org-columns-current-maxwidths
- (org-columns-get-autowidth-alist fmt cache))
- (org-columns-display-here-title)
+ (org-columns--autowidth-alist cache))
+ (org-columns--display-here-title)
(when (setq-local org-columns-flyspell-was-active
(org-bound-and-true-p flyspell-mode))
(flyspell-mode 0))
- (dolist (x cache)
- (goto-char (car x))
- (org-columns-display-here (cdr x)))
+ (dolist (entry cache)
+ (goto-char (car entry))
+ (org-columns--display-here (cdr entry)))
(when org-agenda-columns-show-summaries
(org-agenda-colview-summarize cache)))))))
(defun org-agenda-colview-summarize (cache)
"Summarize the summarizable columns in column view in the agenda.
This will add overlays to the date lines, to show the summary for each day."
- (let* ((fmt (mapcar (lambda (x)
- (if (string-match "CLOCKSUM.*" (car x))
- (list (match-string 0 (car x))
- (nth 1 x) (nth 2 x) ":" 'add_times
- nil '+ nil)
- x))
- org-columns-current-fmt-compiled))
- line c c1 stype calc sumfunc props lsum entries prop v)
- (catch 'exit
- (when (delq nil (mapcar 'cadr fmt))
- ;; OK, at least one summation column, it makes sense to try this
- (goto-char (point-max))
- (while t
- (when (or (get-text-property (point) 'org-date-line)
- (eq (get-text-property (point) 'face)
- 'org-agenda-structure))
- ;; OK, this is a date line that should be used
- (setq line (org-current-line))
- (setq entries nil c cache cache nil)
- (while (setq c1 (pop c))
- (if (> (car c1) line)
- (push c1 entries)
- (push c1 cache)))
- ;; now ENTRIES are the ones we want to use, CACHE is the rest
- ;; Compute the summaries for the properties we want,
- ;; set nil properties for the rest.
- (when (setq entries (mapcar 'cdr entries))
- (setq props
- (mapcar
- (lambda (f)
- (setq prop (car f)
- stype (nth 4 f)
- sumfunc (nth 6 f)
- calc (or (nth 7 f) 'identity))
- (cond
- ((equal prop "ITEM")
- (cons prop (buffer-substring (point-at-bol)
- (point-at-eol))))
- ((not stype) (cons prop ""))
- (t ;; do the summary
- (setq lsum nil)
- (dolist (x entries)
- (setq v (cdr (assoc-string prop x t)))
- (if v
- (push
- (funcall
- (if (not (get-text-property 0 'org-computed v))
- calc
- 'identity)
- (org-columns-string-to-number
- v stype))
- lsum)))
- (setq lsum (remove nil lsum))
- (setq lsum
- (cond ((> (length lsum) 1)
- (org-columns-number-to-string
- (apply sumfunc lsum) stype))
- ((eq (length lsum) 1)
- (org-columns-number-to-string
- (car lsum) stype))
- (t "")))
- (put-text-property 0 (length lsum) 'face 'bold lsum)
- (unless (eq calc 'identity)
- (put-text-property 0 (length lsum) 'org-computed t lsum))
- (cons prop lsum))))
- fmt))
- (org-columns-display-here props 'dateline)
- (setq-local org-agenda-columns-active t)))
- (if (bobp) (throw 'exit t))
- (beginning-of-line 0))))))
+ (let ((fmt (mapcar
+ (lambda (spec)
+ (pcase spec
+ (`(,property ,title ,width . ,_)
+ (if (member-ignore-case property '("CLOCKSUM" "CLOCKSUM_T"))
+ (list property title width ":" 'add_times nil '+ nil)
+ spec))))
+ org-columns-current-fmt-compiled))
+ entries)
+ ;; Ensure there's at least one summation column.
+ (when (cl-some (lambda (spec) (nth 4 spec)) fmt)
+ (goto-char (point-max))
+ (while (not (bobp))
+ (when (or (get-text-property (point) 'org-date-line)
+ (eq (get-text-property (point) 'face)
+ 'org-agenda-structure))
+ ;; OK, this is a date line that should be used.
+ (let (rest)
+ (dolist (c cache (setq cache rest))
+ (if (> (car c) (point))
+ (push c entries)
+ (push c rest))))
+ ;; Now ENTRIES contains entries below the current one.
+ ;; CACHE is the rest. Compute the summaries for the
+ ;; properties we want, set nil properties for the rest.
+ (when (setq entries (mapcar 'cdr entries))
+ (org-columns--display-here
+ (mapcar
+ (lambda (spec)
+ (pcase spec
+ (`(,(and prop (guard (equal (upcase prop) "ITEM"))) . ,_)
+ ;; Replace ITEM with current date. Preserve
+ ;; properties for fontification.
+ (let ((date (buffer-substring
+ (line-beginning-position)
+ (line-end-position))))
+ (list prop date date)))
+ (`(,prop ,_ ,_ ,_ nil . ,_)
+ (list prop "" ""))
+ (`(,prop ,_ ,_ ,_ ,stype ,_ ,sumfunc ,calc)
+ (let (lsum)
+ (dolist (entry entries (setq lsum (delq nil lsum)))
+ ;; Use real values for summary, not those
+ ;; prepared for display.
+ (let ((v (nth 1 (assoc-string prop entry t))))
+ (when v
+ (let ((n (org-columns-string-to-number v stype)))
+ (push
+ (if (or (get-text-property 0 'org-computed v)
+ (not calc))
+ n
+ (funcall calc n))
+ lsum)))))
+ (setq lsum
+ (let ((l (length lsum)))
+ (cond ((> l 1)
+ (org-columns-number-to-string
+ (apply sumfunc lsum) stype))
+ ((= l 1)
+ (org-columns-number-to-string
+ (car lsum) stype))
+ (t ""))))
+ (unless (memq calc '(identity nil))
+ (put-text-property 0 (length lsum) 'org-computed t lsum))
+ (put-text-property 0 (length lsum) 'face 'bold lsum)
+ (list prop lsum lsum)))))
+ fmt)
+ 'dateline)
+ (setq-local org-agenda-columns-active t)))
+ (forward-line -1)))))
(defun org-agenda-colview-compute (fmt)
"Compute the relevant columns in the contributing source buffers."