lisp/org-colview.el

   1 ;;; org-colview.el --- Column View in Org            -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2004-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Carsten Dominik <carsten at orgmode dot org>
   6 ;; Keywords: outlines, hypermedia, calendar, wp
   7 ;; Homepage: http://orgmode.org
   8 ;;
   9 ;; This file is part of GNU Emacs.
  10 ;;
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;;
  25 ;;; Commentary:
  26
  27 ;; This file contains the column view for Org.
  28
  29 ;;; Code:
  30
  31 (require 'cl-lib)
  32 (require 'org)
  33
  34 (declare-function org-agenda-redo "org-agenda" ())
  35 (declare-function org-agenda-do-context-action "org-agenda" ())
  36 (declare-function org-clock-sum-today "org-clock" (&optional headline-filter))
  37 (declare-function org-element-extract-element "org-element" (element))
  38 (declare-function org-element-interpret-data "org-element" (data))
  39 (declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated))
  40 (declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent))
  41 (declare-function org-element-restriction "org-element" (element))
  42
  43 (defvar org-agenda-columns-add-appointments-to-effort-sum)
  44 (defvar org-agenda-columns-compute-summary-properties)
  45 (defvar org-agenda-columns-show-summaries)
  46 (defvar org-agenda-view-columns-initially)
  47 (defvar org-inlinetask-min-level)
  48
  49 \f
  50 ;;; Configuration
  51
  52 (defcustom org-columns-modify-value-for-display-function nil
  53   "Function that modifies values for display in column view.
  54 For example, it can be used to cut out a certain part from a time stamp.
  55 The function must take 2 arguments:
  56
  57 column-title    The title of the column (*not* the property name)
  58 value           The value that should be modified.
  59
  60 The function should return the value that should be displayed,
  61 or nil if the normal value should be used."
  62   :group 'org-properties
  63   :type '(choice (const nil) (function)))
  64
  65 (defcustom org-columns-summary-types nil
  66   "Alist between operators and summarize functions.
  67
  68 Each association follows the pattern (LABEL . SUMMARIZE) where
  69
  70   LABEL is a string used in #+COLUMNS definition describing the
  71   summary type.  It can contain any character but \"}\".  It is
  72   case-sensitive.
  73
  74   SUMMARIZE is a function called with two arguments.  The first
  75   argument is a non-empty list of values, as non-empty strings.
  76   The second one is a format string or nil.  It has to return
  77   a string summarizing the list of values.
  78
  79 Note that the return value can become one value for an higher
  80 order summary, so the function is expected to handle its own
  81 output.
  82
  83 Types defined in this variable take precedence over those defined
  84 in `org-columns-summary-types-default', which see."
  85   :group 'org-properties
  86   :version "25.1"
  87   :package-version '(Org . "9.0")
  88   :type '(alist :key-type (string :tag "       Label")
  89                 :value-type (function :tag "Summarize")))
  90
  91
  92 \f
  93 ;;; Column View
  94
  95 (defvar org-columns-overlays nil
  96   "Holds the list of current column overlays.")
  97
  98 (defvar org-columns--time 0.0
  99   "Number of seconds since the epoch, as a floating point number.")
 100
 101 (defvar-local org-columns-current-fmt nil
 102   "Local variable, holds the currently active column format.")
 103 (defvar-local org-columns-current-fmt-compiled nil
 104   "Local variable, holds the currently active column format.
 105 This is the compiled version of the format.")
 106 (defvar-local org-columns-current-maxwidths nil
 107   "Loval variable, holds the currently active maximum column widths.")
 108 (defvar org-columns-begin-marker (make-marker)
 109   "Points to the position where last a column creation command was called.")
 110 (defvar org-columns-top-level-marker (make-marker)
 111   "Points to the position where current columns region starts.")
 112
 113 (defvar org-columns-map (make-sparse-keymap)
 114   "The keymap valid in column display.")
 115
 116 (defconst org-columns-summary-types-default
 117   '(("+"     . org-columns--summary-sum)
 118     ("$"     . org-columns--summary-currencies)
 119     ("X"     . org-columns--summary-checkbox)
 120     ("X/"    . org-columns--summary-checkbox-count)
 121     ("X%"    . org-columns--summary-checkbox-percent)
 122     ("max"   . org-columns--summary-max)
 123     ("mean"  . org-columns--summary-mean)
 124     ("min"   . org-columns--summary-min)
 125     (":"     . org-columns--summary-sum-times)
 126     (":max"  . org-columns--summary-max-time)
 127     (":mean" . org-columns--summary-mean-time)
 128     (":min"  . org-columns--summary-min-time)
 129     ("@max"  . org-columns--summary-max-age)
 130     ("@mean" . org-columns--summary-mean-age)
 131     ("@min"  . org-columns--summary-min-age)
 132     ("est+"  . org-columns--summary-estimate))
 133   "Map operators to summarize functions.
 134 See `org-columns-summary-types' for details.")
 135
 136 (defun org-columns-content ()
 137   "Switch to contents view while in columns view."
 138   (interactive)
 139   (org-overview)
 140   (org-content))
 141
 142 (org-defkey org-columns-map "c" 'org-columns-content)
 143 (org-defkey org-columns-map "o" 'org-overview)
 144 (org-defkey org-columns-map "e" 'org-columns-edit-value)
 145 (org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo)
 146 (org-defkey org-columns-map "\C-c\C-c" 'org-columns-set-tags-or-toggle)
 147 (org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link)
 148 (org-defkey org-columns-map "v" 'org-columns-show-value)
 149 (org-defkey org-columns-map "q" 'org-columns-quit)
 150 (org-defkey org-columns-map "r" 'org-columns-redo)
 151 (org-defkey org-columns-map "g" 'org-columns-redo)
 152 (org-defkey org-columns-map [left] 'backward-char)
 153 (org-defkey org-columns-map "\M-b" 'backward-char)
 154 (org-defkey org-columns-map "a" 'org-columns-edit-allowed)
 155 (org-defkey org-columns-map "s" 'org-columns-edit-attributes)
 156 (org-defkey org-columns-map "\M-f"
 157             (lambda () (interactive) (goto-char (1+ (point)))))
 158 (org-defkey org-columns-map [right]
 159             (lambda () (interactive) (goto-char (1+ (point)))))
 160 (org-defkey org-columns-map [down]
 161             (lambda () (interactive)
 162               (let ((col (current-column)))
 163                 (beginning-of-line 2)
 164                 (while (and (org-invisible-p2) (not (eobp)))
 165                   (beginning-of-line 2))
 166                 (move-to-column col)
 167                 (if (eq major-mode 'org-agenda-mode)
 168                     (org-agenda-do-context-action)))))
 169 (org-defkey org-columns-map [up]
 170             (lambda () (interactive)
 171               (let ((col (current-column)))
 172                 (beginning-of-line 0)
 173                 (while (and (org-invisible-p2) (not (bobp)))
 174                   (beginning-of-line 0))
 175                 (move-to-column col)
 176                 (if (eq major-mode 'org-agenda-mode)
 177                     (org-agenda-do-context-action)))))
 178 (org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
 179 (org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
 180 (org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
 181 (org-defkey org-columns-map "p" 'org-columns-previous-allowed-value)
 182 (org-defkey org-columns-map "<" 'org-columns-narrow)
 183 (org-defkey org-columns-map ">" 'org-columns-widen)
 184 (org-defkey org-columns-map [(meta right)] 'org-columns-move-right)
 185 (org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
 186 (org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
 187 (org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
 188 (dotimes (i 10)
 189   (org-defkey org-columns-map (number-to-string i)
 190               `(lambda () (interactive)
 191                  (org-columns-next-allowed-value nil ,i))))
 192
 193 (easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
 194   '("Column"
 195     ["Edit property" org-columns-edit-value t]
 196     ["Next allowed value" org-columns-next-allowed-value t]
 197     ["Previous allowed value" org-columns-previous-allowed-value t]
 198     ["Show full value" org-columns-show-value t]
 199     ["Edit allowed values" org-columns-edit-allowed t]
 200     "--"
 201     ["Edit column attributes" org-columns-edit-attributes t]
 202     ["Increase column width" org-columns-widen t]
 203     ["Decrease column width" org-columns-narrow t]
 204     "--"
 205     ["Move column right" org-columns-move-right t]
 206     ["Move column left" org-columns-move-left t]
 207     ["Add column" org-columns-new t]
 208     ["Delete column" org-columns-delete t]
 209     "--"
 210     ["CONTENTS" org-columns-content t]
 211     ["OVERVIEW" org-overview t]
 212     ["Refresh columns display" org-columns-redo t]
 213     "--"
 214     ["Open link" org-columns-open-link t]
 215     "--"
 216     ["Quit" org-columns-quit t]))
 217
 218 (defun org-columns--displayed-value (property value)
 219   "Return displayed value for PROPERTY in current entry.
 220
 221 VALUE is the real value of the property, as a string.
 222
 223 This function assumes `org-columns-current-fmt-compiled' is
 224 initialized."
 225   (cond
 226    ((and (functionp org-columns-modify-value-for-display-function)
 227          (funcall
 228           org-columns-modify-value-for-display-function
 229           (nth 1 (assoc-string property org-columns-current-fmt-compiled t))
 230           value)))
 231    ((equal (upcase property) "ITEM")
 232     (concat (make-string (1- (org-current-level))
 233                          (if org-hide-leading-stars ?\s ?*))
 234             "* "
 235             (org-columns-compact-links value)))
 236    (value)))
 237
 238 (defun org-columns--collect-values (&optional agenda)
 239   "Collect values for columns on the current line.
 240
 241 When optional argument AGENDA is non-nil, assume the value is
 242 meant for the agenda, i.e., caller is `org-agenda-columns'.
 243
 244 Return a list of triplets (PROPERTY VALUE DISPLAYED) suitable for
 245 `org-columns--display-here'.
 246
 247 This function assumes `org-columns-current-fmt-compiled' is
 248 initialized."
 249   (mapcar
 250    (lambda (spec)
 251      (let* ((p (car spec))
 252             (v (or (cdr (assoc-string
 253                          p (get-text-property (point) 'org-summaries) t))
 254                    (org-entry-get (point) p 'selective t)
 255                    (and agenda
 256                         ;; Effort property is not defined.  Try to use
 257                         ;; appointment duration.
 258                         org-agenda-columns-add-appointments-to-effort-sum
 259                         (string= (upcase p) (upcase org-effort-property))
 260                         (get-text-property (point) 'duration)
 261                         (org-propertize
 262                          (org-minutes-to-clocksum-string
 263                           (get-text-property (point) 'duration))
 264                          'face 'org-warning))
 265                    "")))
 266        (list p v (org-columns--displayed-value p v))))
 267    org-columns-current-fmt-compiled))
 268
 269 (defun org-columns--autowidth-alist (cache)
 270   "Derive the maximum column widths from the format and the cache.
 271 Return an alist (PROPERTY . WIDTH), with PROPERTY as a string and
 272 WIDTH as an integer greater than 0."
 273   (mapcar
 274    (lambda (spec)
 275      (pcase spec
 276        (`(,property ,name ,width . ,_)
 277         (if width (cons property width)
 278           ;; No width is specified in the columns format.  Compute it
 279           ;; by checking all possible values for PROPERTY.
 280           (let ((width (length name)))
 281             (dolist (entry cache (cons property width))
 282               (let ((value (nth 2 (assoc-string property (cdr entry) t))))
 283                 (setq width (max (length value) width)))))))))
 284    org-columns-current-fmt-compiled))
 285
 286 (defun org-columns-new-overlay (beg end &optional string face)
 287   "Create a new column overlay and add it to the list."
 288   (let ((ov (make-overlay beg end)))
 289     (overlay-put ov 'face (or face 'secondary-selection))
 290     (org-overlay-display ov string face)
 291     (push ov org-columns-overlays)
 292     ov))
 293
 294 (defun org-columns--summarize (operator)
 295   "Return summary function associated to string OPERATOR."
 296   (cdr (or (assoc operator org-columns-summary-types)
 297            (assoc operator org-columns-summary-types-default))))
 298
 299 (defun org-columns--overlay-text (value fmt width property original)
 300   "Return text "
 301   (format fmt
 302           (let ((v (org-columns-add-ellipses value width)))
 303             (pcase (upcase property)
 304               ("PRIORITY"
 305                (propertize v 'face (org-get-priority-face original)))
 306               ("TAGS"
 307                (if (not org-tags-special-faces-re)
 308                    (propertize v 'face 'org-tag)
 309                  (replace-regexp-in-string
 310                   org-tags-special-faces-re
 311                   (lambda (m) (propertize m 'face (org-get-tag-face m)))
 312                   v nil nil 1)))
 313               ("TODO" (propertize v 'face (org-get-todo-face original)))
 314               (_ v)))))
 315
 316 (defun org-columns--display-here (columns &optional dateline)
 317   "Overlay the current line with column display.
 318 COLUMNS is an alist (PROPERTY VALUE DISPLAYED).  Optional
 319 argument DATELINE is non-nil when the face used should be
 320 `org-agenda-column-dateline'."
 321   (save-excursion
 322     (beginning-of-line)
 323     (let* ((level-face (and (looking-at "\\(\\**\\)\\(\\* \\)")
 324                             (org-get-level-face 2)))
 325            (ref-face (or level-face
 326                          (and (eq major-mode 'org-agenda-mode)
 327                               (org-get-at-bol 'face))
 328                          'default))
 329            (color (list :foreground (face-attribute ref-face :foreground)))
 330            (font (list :height (face-attribute 'default :height)
 331                        :family (face-attribute 'default :family)))
 332            (face (list color font 'org-column ref-face))
 333            (face1 (list color font 'org-agenda-column-dateline ref-face)))
 334       ;; Each column is an overlay on top of a character.  So there has
 335       ;; to be at least as many characters available on the line as
 336       ;; columns to display.
 337       (let ((columns (length org-columns-current-fmt-compiled))
 338             (chars (- (line-end-position) (line-beginning-position))))
 339         (when (> columns chars)
 340           (save-excursion
 341             (end-of-line)
 342             (let ((inhibit-read-only t))
 343               (insert (make-string (- columns chars) ?\s))))))
 344       ;; Display columns.  Create and install the overlay for the
 345       ;; current column on the next character.
 346       (let ((limit (+ (- (length columns) 1) (line-beginning-position))))
 347         (dolist (column columns)
 348           (pcase column
 349             (`(,property ,original ,value)
 350              (let* ((width
 351                      (cdr
 352                       (assoc-string property org-columns-current-maxwidths t)))
 353                     (fmt (format (if (= (point) limit) "%%-%d.%ds |"
 354                                    "%%-%d.%ds | ")
 355                                  width width))
 356                     (ov (org-columns-new-overlay
 357                          (point) (1+ (point))
 358                          (org-columns--overlay-text
 359                           value fmt width property original)
 360                          (if dateline face1 face))))
 361                (overlay-put ov 'keymap org-columns-map)
 362                (overlay-put ov 'org-columns-key property)
 363                (overlay-put ov 'org-columns-value original)
 364                (overlay-put ov 'org-columns-value-modified value)
 365                (overlay-put ov 'org-columns-format fmt)
 366                (overlay-put ov 'line-prefix "")
 367                (overlay-put ov 'wrap-prefix "")
 368                (forward-char))))))
 369       ;; Make the rest of the line disappear.
 370       (let ((ov (org-columns-new-overlay (point) (line-end-position))))
 371         (overlay-put ov 'invisible t)
 372         (overlay-put ov 'keymap org-columns-map)
 373         (overlay-put ov 'line-prefix "")
 374         (overlay-put ov 'wrap-prefix ""))
 375       (let ((ov (make-overlay (1- (line-end-position))
 376                               (line-beginning-position 2))))
 377         (overlay-put ov 'keymap org-columns-map)
 378         (push ov org-columns-overlays))
 379       (org-with-silent-modifications
 380        (let ((inhibit-read-only t))
 381          (put-text-property
 382           (line-end-position 0)
 383           (line-beginning-position 2)
 384           'read-only
 385           (substitute-command-keys
 386            "Type \\<org-columns-map>\\[org-columns-edit-value] \
 387 to edit property")))))))
 388
 389 (defun org-columns-add-ellipses (string width)
 390   "Truncate STRING with WIDTH characters, with ellipses."
 391   (cond
 392    ((<= (length string) width) string)
 393    ((<= width (length org-columns-ellipses))
 394     (substring org-columns-ellipses 0 width))
 395    (t (concat (substring string 0 (- width (length org-columns-ellipses)))
 396               org-columns-ellipses))))
 397
 398 (defvar org-columns-full-header-line-format nil
 399   "The full header line format, will be shifted by horizontal scrolling." )
 400 (defvar org-previous-header-line-format nil
 401   "The header line format before column view was turned on.")
 402 (defvar org-columns-inhibit-recalculation nil
 403   "Inhibit recomputing of columns on column view startup.")
 404 (defvar org-columns-flyspell-was-active nil
 405   "Remember the state of `flyspell-mode' before column view.
 406 Flyspell-mode can cause problems in columns view, so it is turned off
 407 for the duration of the command.")
 408
 409 (defvar header-line-format)
 410 (defvar org-columns-previous-hscroll 0)
 411
 412 (defun org-columns--display-here-title ()
 413   "Overlay the newline before the current line with the table title."
 414   (interactive)
 415   (let ((title ""))
 416     (dolist (column org-columns-current-fmt-compiled)
 417       (pcase column
 418         (`(,property ,name . ,_)
 419          (let* ((width
 420                  (cdr (assoc-string property org-columns-current-maxwidths t)))
 421                 (fmt (format "%%-%d.%ds | " width width)))
 422            (setq title (concat title (format fmt (or name property))))))))
 423     (setq-local org-previous-header-line-format header-line-format)
 424     (setq org-columns-full-header-line-format
 425           (concat
 426            (org-add-props " " nil 'display '(space :align-to 0))
 427            (org-add-props (substring title 0 -1) nil 'face 'org-column-title)))
 428     (setq org-columns-previous-hscroll -1)
 429     (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local)))
 430
 431 (defun org-columns-hscoll-title ()
 432   "Set the `header-line-format' so that it scrolls along with the table."
 433   (sit-for .0001) ; need to force a redisplay to update window-hscroll
 434   (when (not (= (window-hscroll) org-columns-previous-hscroll))
 435     (setq header-line-format
 436           (concat (substring org-columns-full-header-line-format 0 1)
 437                   (substring org-columns-full-header-line-format
 438                              (1+ (window-hscroll))))
 439           org-columns-previous-hscroll (window-hscroll))
 440     (force-mode-line-update)))
 441
 442 (defvar org-colview-initial-truncate-line-value nil
 443   "Remember the value of `truncate-lines' across colview.")
 444
 445 ;;;###autoload
 446 (defun org-columns-remove-overlays ()
 447   "Remove all currently active column overlays."
 448   (interactive)
 449   (when (marker-buffer org-columns-begin-marker)
 450     (with-current-buffer (marker-buffer org-columns-begin-marker)
 451       (when (local-variable-p 'org-previous-header-line-format)
 452         (setq header-line-format org-previous-header-line-format)
 453         (kill-local-variable 'org-previous-header-line-format)
 454         (remove-hook 'post-command-hook 'org-columns-hscoll-title 'local))
 455       (move-marker org-columns-begin-marker nil)
 456       (move-marker org-columns-top-level-marker nil)
 457       (org-with-silent-modifications
 458        (mapc 'delete-overlay org-columns-overlays)
 459        (setq org-columns-overlays nil)
 460        (let ((inhibit-read-only t))
 461          (remove-text-properties (point-min) (point-max) '(read-only t))))
 462       (when org-columns-flyspell-was-active
 463         (flyspell-mode 1))
 464       (when (local-variable-p 'org-colview-initial-truncate-line-value)
 465         (setq truncate-lines org-colview-initial-truncate-line-value)))))
 466
 467 (defun org-columns-compact-links (s)
 468   "Replace [[link][desc]] with [desc] or [link]."
 469   (while (string-match org-bracket-link-regexp s)
 470     (setq s (replace-match
 471              (concat "[" (match-string (if (match-end 3) 3 1) s) "]")
 472              t t s)))
 473   s)
 474
 475 (defun org-columns-show-value ()
 476   "Show the full value of the property."
 477   (interactive)
 478   (let ((value (get-char-property (point) 'org-columns-value)))
 479     (message "Value is: %s" (or value ""))))
 480
 481 (defvar org-agenda-columns-active) ;; defined in org-agenda.el
 482
 483 (defun org-columns-quit ()
 484   "Remove the column overlays and in this way exit column editing."
 485   (interactive)
 486   (org-with-silent-modifications
 487    (org-columns-remove-overlays)
 488    (let ((inhibit-read-only t))
 489      (remove-text-properties (point-min) (point-max) '(read-only t))))
 490   (when (eq major-mode 'org-agenda-mode)
 491     (setq org-agenda-columns-active nil)
 492     (message
 493      "Modification not yet reflected in Agenda buffer, use `r' to refresh")))
 494
 495 (defun org-columns-check-computed ()
 496   "Check if this column value is computed.
 497 If yes, throw an error indicating that changing it does not make sense."
 498   (let ((val (get-char-property (point) 'org-columns-value)))
 499     (when (and (stringp val)
 500                (get-char-property 0 'org-computed val))
 501       (error "This value is computed from the entry's children"))))
 502
 503 (defun org-columns-todo (&optional _arg)
 504   "Change the TODO state during column view."
 505   (interactive "P")
 506   (org-columns-edit-value "TODO"))
 507
 508 (defun org-columns-set-tags-or-toggle (&optional _arg)
 509   "Toggle checkbox at point, or set tags for current headline."
 510   (interactive "P")
 511   (if (string-match "\\`\\[[ xX-]\\]\\'"
 512                     (get-char-property (point) 'org-columns-value))
 513       (org-columns-next-allowed-value)
 514     (org-columns-edit-value "TAGS")))
 515
 516 (defvar org-agenda-overriding-columns-format nil
 517   "When set, overrides any other format definition for the agenda.
 518 Don't set this, this is meant for dynamic scoping.")
 519
 520 (defun org-columns-edit-value (&optional key)
 521   "Edit the value of the property at point in column view.
 522 Where possible, use the standard interface for changing this line."
 523   (interactive)
 524   (org-columns-check-computed)
 525   (let* ((col (current-column))
 526          (key (or key (get-char-property (point) 'org-columns-key)))
 527          (value (get-char-property (point) 'org-columns-value))
 528          (bol (point-at-bol)) (eol (point-at-eol))
 529          (pom (or (get-text-property bol 'org-hd-marker)
 530                   (point)))          ; keep despite of compiler waring
 531          (org-columns--time (float-time (current-time)))
 532          nval eval allowed)
 533     (cond
 534      ((equal key "CLOCKSUM")
 535       (error "This special column cannot be edited"))
 536      ((equal key "ITEM")
 537       (setq eval `(org-with-point-at ,pom
 538                     (org-edit-headline))))
 539      ((equal key "TODO")
 540       (setq eval `(org-with-point-at ,pom
 541                     (call-interactively 'org-todo))))
 542      ((equal key "PRIORITY")
 543       (setq eval `(org-with-point-at ,pom
 544                     (call-interactively 'org-priority))))
 545      ((equal key "TAGS")
 546       (setq eval `(org-with-point-at ,pom
 547                     (let ((org-fast-tag-selection-single-key
 548                            (if (eq org-fast-tag-selection-single-key 'expert)
 549                                t org-fast-tag-selection-single-key)))
 550                       (call-interactively 'org-set-tags)))))
 551      ((equal key "DEADLINE")
 552       (setq eval `(org-with-point-at ,pom
 553                     (call-interactively 'org-deadline))))
 554      ((equal key "SCHEDULED")
 555       (setq eval `(org-with-point-at ,pom
 556                     (call-interactively 'org-schedule))))
 557      ((equal key "BEAMER_env")
 558       (setq eval `(org-with-point-at ,pom
 559                     (call-interactively 'org-beamer-select-environment))))
 560      (t
 561       (setq allowed (org-property-get-allowed-values pom key 'table))
 562       (if allowed
 563           (setq nval (completing-read
 564                       "Value: " allowed nil
 565                       (not (get-text-property 0 'org-unrestricted
 566                                               (caar allowed)))))
 567         (setq nval (read-string "Edit: " value)))
 568       (setq nval (org-trim nval))
 569       (when (not (equal nval value))
 570         (setq eval `(org-entry-put ,pom ,key ,nval)))))
 571     (when eval
 572       (cond
 573        ((equal major-mode 'org-agenda-mode)
 574         (org-columns-eval eval)
 575         ;; The following let preserves the current format, and makes sure
 576         ;; that in only a single file things need to be updated.
 577         (let* ((org-agenda-overriding-columns-format org-columns-current-fmt)
 578                (buffer (marker-buffer pom))
 579                (org-agenda-contributing-files
 580                 (list (with-current-buffer buffer
 581                         (buffer-file-name (buffer-base-buffer))))))
 582           (org-agenda-columns)))
 583        (t
 584         (let ((inhibit-read-only t))
 585           (org-with-silent-modifications
 586            (remove-text-properties
 587             (max (point-min) (1- bol)) eol '(read-only t)))
 588           (org-columns-eval eval))
 589         (org-move-to-column col)
 590         (org-columns-update key))))))
 591
 592 (defun org-edit-headline () ; FIXME: this is not columns specific.  Make interactive?????  Use from agenda????
 593   "Edit the current headline, the part without TODO keyword, TAGS."
 594   (org-back-to-heading)
 595   (when (looking-at org-todo-line-regexp)
 596     (let ((pos (point))
 597           (pre (buffer-substring (match-beginning 0) (match-beginning 3)))
 598           (txt (match-string 3))
 599           (post "")
 600           txt2)
 601       (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt)
 602           (setq post (match-string 0 txt)
 603                 txt (substring txt 0 (match-beginning 0))))
 604       (setq txt2 (read-string "Edit: " txt))
 605       (when (not (equal txt txt2))
 606         (goto-char pos)
 607         (insert pre txt2 post)
 608         (delete-region (point) (point-at-eol))
 609         (org-set-tags nil t)))))
 610
 611 (defun org-columns-edit-allowed ()
 612   "Edit the list of allowed values for the current property."
 613   (interactive)
 614   (let* ((pom (or (org-get-at-bol 'org-marker)
 615                   (org-get-at-bol 'org-hd-marker)
 616                   (point)))
 617          (key (get-char-property (point) 'org-columns-key))
 618          (key1 (concat key "_ALL"))
 619          (allowed (org-entry-get pom key1 t))
 620          nval)
 621     ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.????
 622     ;; FIXME: Write back to #+PROPERTY setting if that is needed.
 623     (setq nval (read-string "Allowed: " allowed))
 624     (org-entry-put
 625      (cond ((marker-position org-entry-property-inherited-from)
 626             org-entry-property-inherited-from)
 627            ((marker-position org-columns-top-level-marker)
 628             org-columns-top-level-marker)
 629            (t pom))
 630      key1 nval)))
 631
 632 (defun org-columns-eval (form)
 633   (let (hidep)
 634     (save-excursion
 635       (beginning-of-line 1)
 636       ;; `next-line' is needed here, because it skips invisible line.
 637       (condition-case nil (org-no-warnings (next-line 1)) (error nil))
 638       (setq hidep (org-at-heading-p 1)))
 639     (eval form)
 640     (and hidep (outline-hide-entry))))
 641
 642 (defun org-columns-previous-allowed-value ()
 643   "Switch to the previous allowed value for this column."
 644   (interactive)
 645   (org-columns-next-allowed-value t))
 646
 647 (defun org-columns-next-allowed-value (&optional previous nth)
 648   "Switch to the next allowed value for this column.
 649 When PREVIOUS is set, go to the previous value.  When NTH is
 650 an integer, select that value."
 651   (interactive)
 652   (org-columns-check-computed)
 653   (let* ((col (current-column))
 654          (key (get-char-property (point) 'org-columns-key))
 655          (value (get-char-property (point) 'org-columns-value))
 656          (bol (point-at-bol)) (eol (point-at-eol))
 657          (pom (or (get-text-property bol 'org-hd-marker)
 658                   (point)))          ; keep despite of compiler waring
 659          (allowed
 660           (or (org-property-get-allowed-values pom key)
 661               (and (member (nth 3 (assoc-string key
 662                                                 org-columns-current-fmt-compiled
 663                                                 t))
 664                            '("X" "X/" "X%"))
 665                    '("[ ]" "[X]"))
 666               (org-colview-construct-allowed-dates value)))
 667          nval)
 668     (when (integerp nth)
 669       (setq nth (1- nth))
 670       (if (= nth -1) (setq nth 9)))
 671     (when (equal key "ITEM")
 672       (error "Cannot edit item headline from here"))
 673     (unless (or allowed (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")))
 674       (error "Allowed values for this property have not been defined"))
 675     (if (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM"))
 676         (setq nval (if previous 'earlier 'later))
 677       (if previous (setq allowed (reverse allowed)))
 678       (cond
 679        (nth
 680         (setq nval (nth nth allowed))
 681         (if (not nval)
 682             (error "There are only %d allowed values for property `%s'"
 683                    (length allowed) key)))
 684        ((member value allowed)
 685         (setq nval (or (car (cdr (member value allowed)))
 686                        (car allowed)))
 687         (if (equal nval value)
 688             (error "Only one allowed value for this property")))
 689        (t (setq nval (car allowed)))))
 690     (cond
 691      ((equal major-mode 'org-agenda-mode)
 692       (org-columns-eval `(org-entry-put ,pom ,key ,nval))
 693       ;; The following let preserves the current format, and makes sure
 694       ;; that in only a single file things need to be updated.
 695       (let* ((org-agenda-overriding-columns-format org-columns-current-fmt)
 696              (buffer (marker-buffer pom))
 697              (org-agenda-contributing-files
 698               (list (with-current-buffer buffer
 699                       (buffer-file-name (buffer-base-buffer))))))
 700         (org-agenda-columns)))
 701      (t
 702       (let ((inhibit-read-only t))
 703         (remove-text-properties (max (1- bol) (point-min)) eol '(read-only t))
 704         (org-columns-eval `(org-entry-put ,pom ,key ,nval)))
 705       (org-move-to-column col)
 706       (org-columns-update key)))))
 707
 708 (defun org-colview-construct-allowed-dates (s)
 709   "Construct a list of three dates around the date in S.
 710 This respects the format of the time stamp in S, active or non-active,
 711 and also including time or not.  S must be just a time stamp, no text
 712 around it."
 713   (when (and s (string-match (concat "^" org-ts-regexp3 "$") s))
 714     (let* ((time (org-parse-time-string s 'nodefaults))
 715            (active (equal (string-to-char s) ?<))
 716            (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats))
 717            time-before time-after)
 718       (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]")))
 719       (setf (car time) (or (car time) 0))
 720       (setf (nth 1 time) (or (nth 1 time) 0))
 721       (setf (nth 2 time) (or (nth 2 time) 0))
 722       (setq time-before (copy-sequence time))
 723       (setq time-after (copy-sequence time))
 724       (setf (nth 3 time-before) (1- (nth 3 time)))
 725       (setf (nth 3 time-after) (1+ (nth 3 time)))
 726       (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x)))
 727               (list time-before time time-after)))))
 728
 729 (defun org-columns-open-link (&optional arg)
 730   (interactive "P")
 731   (let ((value (get-char-property (point) 'org-columns-value)))
 732     (org-open-link-from-string value arg)))
 733
 734 ;;;###autoload
 735 (defun org-columns-get-format-and-top-level ()
 736   (let ((fmt (org-columns-get-format)))
 737     (org-columns-goto-top-level)
 738     fmt))
 739
 740 (defun org-columns-get-format (&optional fmt-string)
 741   (interactive)
 742   (let (fmt-as-property fmt)
 743     (when (condition-case nil (org-back-to-heading) (error nil))
 744       (setq fmt-as-property (org-entry-get nil "COLUMNS" t)))
 745     (setq fmt (or fmt-string fmt-as-property org-columns-default-format))
 746     (setq-local org-columns-current-fmt fmt)
 747     (org-columns-compile-format fmt)
 748     fmt))
 749
 750 (defun org-columns-goto-top-level ()
 751   "Move to the beginning of the column view area.
 752 Also sets `org-columns-top-level-marker' to the new position."
 753   (goto-char
 754    (move-marker
 755     org-columns-top-level-marker
 756     (cond ((org-before-first-heading-p) (point-min))
 757           ((org-entry-get nil "COLUMNS" t) org-entry-property-inherited-from)
 758           (t (org-back-to-heading) (point))))))
 759
 760 ;;;###autoload
 761 (defun org-columns (&optional global columns-fmt-string)
 762   "Turn on column view on an Org mode file.
 763
 764 Column view applies to the whole buffer if point is before the
 765 first headline.  Otherwise, it applies to the first ancestor
 766 setting \"COLUMNS\" property.  If there is none, it defaults to
 767 the current headline.  With a \\[universal-argument] prefix \
 768 argument, turn on column
 769 view for the whole buffer unconditionally.
 770
 771 When COLUMNS-FMT-STRING is non-nil, use it as the column format."
 772   (interactive "P")
 773   (org-columns-remove-overlays)
 774   (move-marker org-columns-begin-marker (point))
 775   (org-columns-goto-top-level)
 776   ;; Initialize `org-columns-current-fmt' and
 777   ;; `org-columns-current-fmt-compiled'.
 778   (let ((org-columns--time (float-time (current-time))))
 779     (org-columns-get-format columns-fmt-string)
 780     (unless org-columns-inhibit-recalculation (org-columns-compute-all))
 781     (save-excursion
 782       (save-restriction
 783         (when (and (not global) (org-at-heading-p))
 784           (narrow-to-region (point) (org-end-of-subtree t t)))
 785         (when (assoc-string "CLOCKSUM" org-columns-current-fmt-compiled t)
 786           (org-clock-sum))
 787         (when (assoc-string "CLOCKSUM_T" org-columns-current-fmt-compiled t)
 788           (org-clock-sum-today))
 789         (let ((cache
 790                ;; Collect contents of columns ahead of time so as to
 791                ;; compute their maximum width.
 792                (org-map-entries
 793                 (lambda () (cons (point) (org-columns--collect-values)))
 794                 nil nil (and org-columns-skip-archived-trees 'archive))))
 795           (when cache
 796             (setq-local org-columns-current-maxwidths
 797                         (org-columns--autowidth-alist cache))
 798             (org-columns--display-here-title)
 799             (when (setq-local org-columns-flyspell-was-active
 800                               (org-bound-and-true-p flyspell-mode))
 801               (flyspell-mode 0))
 802             (unless (local-variable-p 'org-colview-initial-truncate-line-value)
 803               (setq-local org-colview-initial-truncate-line-value
 804                           truncate-lines))
 805             (setq truncate-lines t)
 806             (dolist (entry cache)
 807               (goto-char (car entry))
 808               (org-columns--display-here (cdr entry)))))))))
 809
 810 (defun org-columns-new (&optional prop title width operator &rest _)
 811   "Insert a new column, to the left of the current column."
 812   (interactive)
 813   (let* ((automatic (org-string-nw-p prop))
 814          (prop (or prop (completing-read
 815                          "Property: "
 816                          (mapcar #'list (org-buffer-property-keys t nil t)))))
 817          (title (if automatic title
 818                   (read-string (format "Column title [%s]: " prop) prop)))
 819          (width
 820           ;; WIDTH may be nil, but if PROP is provided, assume this is
 821           ;; the expected width.
 822           (if automatic width
 823             ;; Use `read-string' instead of `read-number' to allow
 824             ;; empty width.
 825             (let ((w (read-string "Column width: ")))
 826               (and (org-string-nw-p w) (string-to-number w)))))
 827          (operator
 828           (if automatic operator
 829             (org-string-nw-p
 830              (completing-read
 831               "Summary: "
 832               (delete-dups
 833                (mapcar (lambda (x) (list (car x)))
 834                        (append org-columns-summary-types
 835                                org-columns-summary-types-default)))
 836               nil t))))
 837          (summarize (and prop operator (org-columns--summarize operator)))
 838          (edit
 839           (and prop (assoc-string prop org-columns-current-fmt-compiled t))))
 840     (if edit (setcdr edit (list title width operator nil summarize))
 841       (push (list prop title width operator nil summarize)
 842             (nthcdr (current-column) org-columns-current-fmt-compiled)))
 843     (org-columns-store-format)
 844     (org-columns-redo)))
 845
 846 (defun org-columns-delete ()
 847   "Delete the column at point from columns view."
 848   (interactive)
 849   (let* ((n (current-column))
 850          (title (nth 1 (nth n org-columns-current-fmt-compiled))))
 851     (when (y-or-n-p
 852            (format "Are you sure you want to remove column \"%s\"? " title))
 853       (setq org-columns-current-fmt-compiled
 854             (delq (nth n org-columns-current-fmt-compiled)
 855                   org-columns-current-fmt-compiled))
 856       (org-columns-store-format)
 857       (org-columns-redo)
 858       (if (>= (current-column) (length org-columns-current-fmt-compiled))
 859           (backward-char 1)))))
 860
 861 (defun org-columns-edit-attributes ()
 862   "Edit the attributes of the current column."
 863   (interactive)
 864   (let* ((n (current-column))
 865          (info (nth n org-columns-current-fmt-compiled)))
 866     (apply 'org-columns-new info)))
 867
 868 (defun org-columns-widen (arg)
 869   "Make the column wider by ARG characters."
 870   (interactive "p")
 871   (let* ((n (current-column))
 872          (entry (nth n org-columns-current-fmt-compiled))
 873          (width (or (nth 2 entry)
 874                     (cdr (assoc-string (car entry)
 875                                        org-columns-current-maxwidths
 876                                        t)))))
 877     (setq width (max 1 (+ width arg)))
 878     (setcar (nthcdr 2 entry) width)
 879     (org-columns-store-format)
 880     (org-columns-redo)))
 881
 882 (defun org-columns-narrow (arg)
 883   "Make the column narrower by ARG characters."
 884   (interactive "p")
 885   (org-columns-widen (- arg)))
 886
 887 (defun org-columns-move-right ()
 888   "Swap this column with the one to the right."
 889   (interactive)
 890   (let* ((n (current-column))
 891          (cell (nthcdr n org-columns-current-fmt-compiled))
 892          e)
 893     (when (>= n (1- (length org-columns-current-fmt-compiled)))
 894       (error "Cannot shift this column further to the right"))
 895     (setq e (car cell))
 896     (setcar cell (car (cdr cell)))
 897     (setcdr cell (cons e (cdr (cdr cell))))
 898     (org-columns-store-format)
 899     (org-columns-redo)
 900     (forward-char 1)))
 901
 902 (defun org-columns-move-left ()
 903   "Swap this column with the one to the left."
 904   (interactive)
 905   (let* ((n (current-column)))
 906     (when (= n 0)
 907       (error "Cannot shift this column further to the left"))
 908     (backward-char 1)
 909     (org-columns-move-right)
 910     (backward-char 1)))
 911
 912 (defun org-columns-store-format ()
 913   "Store the text version of the current columns format in appropriate place.
 914 This is either in the COLUMNS property of the node starting the current column
 915 display, or in the #+COLUMNS line of the current buffer."
 916   (let (fmt (cnt 0))
 917     (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))
 918     (setq-local org-columns-current-fmt fmt)
 919     (if (marker-position org-columns-top-level-marker)
 920         (save-excursion
 921           (goto-char org-columns-top-level-marker)
 922           (if (and (org-at-heading-p)
 923                    (org-entry-get nil "COLUMNS"))
 924               (org-entry-put nil "COLUMNS" fmt)
 925             (goto-char (point-min))
 926             ;; Overwrite all #+COLUMNS lines....
 927             (while (re-search-forward "^[ \t]*#\\+COLUMNS:.*" nil t)
 928               (setq cnt (1+ cnt))
 929               (replace-match (concat "#+COLUMNS: " fmt) t t))
 930             (unless (> cnt 0)
 931               (goto-char (point-min))
 932               (or (org-at-heading-p t) (outline-next-heading))
 933               (let ((inhibit-read-only t))
 934                 (insert-before-markers "#+COLUMNS: " fmt "\n")))
 935             (setq-local org-columns-default-format fmt))))))
 936
 937 (defun org-columns-update (property)
 938   "Recompute PROPERTY, and update the columns display for it."
 939   (org-columns-compute property)
 940   (org-with-wide-buffer
 941    (let ((p (upcase property)))
 942      (dolist (ov org-columns-overlays)
 943        (when (let ((key (overlay-get ov 'org-columns-key)))
 944                (and key (equal (upcase key) p) (overlay-start ov)))
 945          (goto-char (overlay-start ov))
 946          (let ((value (cdr
 947                        (assoc-string
 948                         property
 949                         (get-text-property (line-beginning-position)
 950                                            'org-summaries)
 951                         t))))
 952            (when value
 953              (let ((displayed (org-columns--displayed-value property value))
 954                    (format (overlay-get ov 'org-columns-format))
 955                    (width (cdr (assoc-string property
 956                                              org-columns-current-maxwidths
 957                                              t))))
 958                (overlay-put ov 'org-columns-value value)
 959                (overlay-put ov 'org-columns-value-modified displayed)
 960                (overlay-put ov
 961                             'display
 962                             (org-columns--overlay-text
 963                              displayed format width property value))))))))))
 964
 965 (defun org-columns-redo ()
 966   "Construct the column display again."
 967   (interactive)
 968   (message "Recomputing columns...")
 969   (let ((line (org-current-line))
 970         (col (current-column)))
 971     (save-excursion
 972       (if (marker-position org-columns-begin-marker)
 973           (goto-char org-columns-begin-marker))
 974       (org-columns-remove-overlays)
 975       (if (derived-mode-p 'org-mode)
 976           (call-interactively 'org-columns)
 977         (org-agenda-redo)
 978         (call-interactively 'org-agenda-columns)))
 979     (org-goto-line line)
 980     (move-to-column col))
 981   (message "Recomputing columns...done"))
 982
 983 (defun org-columns-uncompile-format (compiled)
 984   "Turn the compiled columns format back into a string representation.
 985 COMPILED is an alist, as returned by
 986 `org-columns-compile-format', which see."
 987   (mapconcat
 988    (lambda (spec)
 989      (pcase spec
 990        (`(,prop ,title ,width ,op ,printf ,_)
 991         (concat "%"
 992                 (and width (number-to-string width))
 993                 prop
 994                 (and title (not (equal prop title)) (format "(%s)" title))
 995                 (cond ((not op) nil)
 996                       (printf (format "{%s;%s}" op printf))
 997                       (t (format "{%s}" op)))))))
 998    compiled " "))
 999
1000 (defun org-columns-compile-format (fmt)
1001   "Turn a column format string FMT into an alist of specifications.
1002
1003 The alist has one entry for each column in the format.  The elements of
1004 that list are:
1005 property    the property name
1006 title       the title field for the columns
1007 width       the column width in characters, can be nil for automatic
1008 operator    the summary operator if any
1009 printf      a printf format for computed values
1010 fun         the lisp function to compute summary values, derived from operator
1011
1012 This function updates `org-columns-current-fmt-compiled'."
1013   (setq org-columns-current-fmt-compiled nil)
1014   (let ((start 0))
1015     (while (string-match
1016             "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\
1017 \\(?:{\\([^}]+\\)}\\)?\\s-*"
1018             fmt start)
1019       (setq start (match-end 0))
1020       (let* ((width (and (match-end 1) (string-to-number (match-string 1 fmt))))
1021              (prop (match-string 2 fmt))
1022              (title (or (match-string 3 fmt) prop))
1023              (operator (match-string 4 fmt)))
1024         (push (if (not operator) (list prop title width nil nil nil)
1025                 (let (printf)
1026                   (when (string-match ";" operator)
1027                     (setq printf (substring operator (match-end 0)))
1028                     (setq operator (substring operator 0 (match-beginning 0))))
1029                   (let* ((summarize
1030                           (or (org-columns--summarize operator)
1031                               (user-error "Cannot find %S summary function"
1032                                           operator))))
1033                     (list prop title width operator printf summarize))))
1034               org-columns-current-fmt-compiled)))
1035     (setq org-columns-current-fmt-compiled
1036           (nreverse org-columns-current-fmt-compiled))))
1037
1038 \f
1039 ;;;; Column View Summary
1040
1041 (defconst org-columns--duration-re
1042   (concat "[0-9.]+ *" (regexp-opt (mapcar #'car org-effort-durations)))
1043   "Regexp matching a duration.")
1044
1045 (defun org-columns--time-to-seconds (s)
1046   "Turn time string S into a number of seconds.
1047 A time is expressed as HH:MM, HH:MM:SS, or with units defined in
1048 `org-effort-durations'.  Plain numbers are considered as hours."
1049   (cond
1050    ((string-match "\\([0-9]+\\):\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" s)
1051     (+ (* 3600 (string-to-number (match-string 1 s)))
1052        (* 60 (string-to-number (match-string 2 s)))
1053        (if (match-end 3) (string-to-number (match-string 3 s)) 0)))
1054    ((string-match-p org-columns--duration-re s)
1055     (* 60 (org-duration-string-to-minutes s)))
1056    (t (* 3600 (string-to-number s)))))
1057
1058 (defun org-columns--age-to-seconds (s)
1059   "Turn age string S into a number of seconds.
1060 An age is either computed from a given time-stamp, or indicated
1061 as days/hours/minutes/seconds."
1062   (cond
1063    ((string-match-p org-ts-regexp s)
1064     (floor
1065      (- org-columns--time
1066         (float-time (apply #'encode-time (org-parse-time-string s))))))
1067    ;; Match own output for computations in upper levels.
1068    ((string-match "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s" s)
1069     (+ (* 86400 (string-to-number (match-string 1 s)))
1070        (* 3600 (string-to-number (match-string 2 s)))
1071        (* 60 (string-to-number (match-string 3 s)))
1072        (string-to-number (match-string 4 s))))
1073    (t (user-error "Invalid age: %S" s))))
1074
1075 (defun org-columns--summary-apply-times (fun times)
1076   "Apply FUN to time values TIMES.
1077 If TIMES contains any time value expressed as a duration, return
1078 the result as a duration.  If it contains any H:M:S, use that
1079 format instead.  Otherwise, use H:M format."
1080   (let* ((hms-flag nil)
1081          (duration-flag nil)
1082          (seconds
1083           (apply fun
1084                  (mapcar
1085                   (lambda (time)
1086                     (cond
1087                      (duration-flag)
1088                      ((string-match-p org-columns--duration-re time)
1089                       (setq duration-flag t))
1090                      (hms-flag)
1091                      ((string-match-p "\\`[0-9]+:[0-9]+:[0-9]+\\'" time)
1092                       (setq hms-flag t)))
1093                     (org-columns--time-to-seconds time))
1094                   times))))
1095     (cond (duration-flag (org-minutes-to-clocksum-string (/ seconds 60.0)))
1096           (hms-flag (format-seconds "%h:%.2m:%.2s" seconds))
1097           (t (format-seconds "%h:%.2m" seconds)))))
1098
1099 ;;;###autoload
1100 (defun org-columns-compute (property)
1101   "Summarize the values of property PROPERTY hierarchically."
1102   (interactive)
1103   (let* ((lmax (if (org-bound-and-true-p org-inlinetask-min-level)
1104                    org-inlinetask-min-level
1105                  29))                   ;Hard-code deepest level.
1106          (lvals (make-vector (1+ lmax) nil))
1107          (spec (assoc-string property org-columns-current-fmt-compiled t))
1108          (printf (nth 4 spec))
1109          (summarize (nth 5 spec))
1110          (level 0)
1111          (inminlevel lmax)
1112          (last-level lmax))
1113     (org-with-wide-buffer
1114      ;; Find the region to compute.
1115      (goto-char org-columns-top-level-marker)
1116      (goto-char (condition-case nil (org-end-of-subtree t) (error (point-max))))
1117      ;; Walk the tree from the back and do the computations.
1118      (while (re-search-backward
1119              org-outline-regexp-bol org-columns-top-level-marker t)
1120        (unless (or (= level 0) (eq level inminlevel))
1121          (setq last-level level))
1122        (setq level (org-reduced-level (org-outline-level)))
1123        (let* ((pos (match-beginning 0))
1124               (value (org-entry-get nil property))
1125               (value-set (org-string-nw-p value)))
1126          (cond
1127           ((< level last-level)
1128            ;; Collect values from lower levels and inline tasks here
1129            ;; and summarize them using SUMMARIZE.  Store them as text
1130            ;; property.
1131            (let* ((summary
1132                    (let ((all (append (and (/= last-level inminlevel)
1133                                            (aref lvals last-level))
1134                                       (aref lvals inminlevel))))
1135                      (and all (funcall summarize all printf)))))
1136              (let* ((summaries-alist (get-text-property pos 'org-summaries))
1137                     (old (assoc-string property summaries-alist t))
1138                     (new
1139                      (cond
1140                       (summary (propertize summary 'org-computed t 'face 'bold))
1141                       (value-set value)
1142                       (t ""))))
1143                (if old (setcdr old new)
1144                  (push (cons property new) summaries-alist)
1145                  (org-with-silent-modifications
1146                   (add-text-properties pos (1+ pos)
1147                                        (list 'org-summaries summaries-alist)))))
1148              ;; When PROPERTY is set in current node, but its value
1149              ;; doesn't match the one computed, use the latter
1150              ;; instead.
1151              (when (and value summary (not (equal value summary)))
1152                (org-entry-put nil property summary))
1153              ;; Add current to current level accumulator.
1154              (when (or summary value-set)
1155                (push (or summary value) (aref lvals level)))
1156              ;; Clear accumulators for deeper levels.
1157              (cl-loop for l from (1+ level) to lmax do
1158                       (aset lvals l nil))))
1159           (value-set (push value (aref lvals level)))
1160           (t nil)))))))
1161
1162 (defun org-columns-compute-all ()
1163   "Compute all columns that have operators defined."
1164   (org-with-silent-modifications
1165    (remove-text-properties (point-min) (point-max) '(org-summaries t)))
1166   (let ((org-columns--time (float-time (current-time))))
1167     (dolist (spec org-columns-current-fmt-compiled)
1168       (pcase spec
1169         (`(,property ,_ ,_ ,operator . ,_)
1170          (when operator (save-excursion (org-columns-compute property))))))))
1171
1172 (defun org-columns--summary-sum (values printf)
1173   "Compute the sum of VALUES.
1174 When PRINTF is non-nil, use it to format the result."
1175   (format (or printf "%s") (apply #'+ (mapcar #'string-to-number values))))
1176
1177 (defun org-columns--summary-currencies (values _)
1178   "Compute the sum of VALUES, with two decimals."
1179   (format "%.2f" (apply #'+ (mapcar #'string-to-number values))))
1180
1181 (defun org-columns--summary-checkbox (check-boxes _)
1182   "Summarize CHECK-BOXES with a check-box."
1183   (let ((done (cl-count "[X]" check-boxes :test #'equal))
1184         (all (length check-boxes)))
1185     (cond ((= done all) "[X]")
1186           ((> done 0) "[-]")
1187           (t "[ ]"))))
1188
1189 (defun org-columns--summary-checkbox-count (check-boxes _)
1190   "Summarize CHECK-BOXES with a check-box cookie."
1191   (format "[%d/%d]"
1192           (cl-count "[X]" check-boxes :test #'equal)
1193           (length check-boxes)))
1194
1195 (defun org-columns--summary-checkbox-percent (check-boxes _)
1196   "Summarize CHECK-BOXES with a check-box percent."
1197   (format "[%d%%]"
1198           (round (* 100.0 (cl-count "[X]" check-boxes :test #'equal))
1199                  (float (length check-boxes)))))
1200
1201 (defun org-columns--summary-min (values printf)
1202   "Compute the minimum of VALUES.
1203 When PRINTF is non-nil, use it to format the result."
1204   (format (or printf "%s")
1205           (apply #'min (mapcar #'string-to-number values))))
1206
1207 (defun org-columns--summary-max (values printf)
1208   "Compute the maximum of VALUES.
1209 When PRINTF is non-nil, use it to format the result."
1210   (format (or printf "%s")
1211           (apply #'max (mapcar #'string-to-number values))))
1212
1213 (defun org-columns--summary-mean (values printf)
1214   "Compute the mean of VALUES.
1215 When PRINTF is non-nil, use it to format the result."
1216   (format (or printf "%s")
1217           (/ (apply #'+ (mapcar #'string-to-number values))
1218              (float (length values)))))
1219
1220 (defun org-columns--summary-sum-times (times _)
1221   "Sum TIMES."
1222   (org-columns--summary-apply-times #'+ times))
1223
1224 (defun org-columns--summary-min-time (times _)
1225   "Compute the minimum time among TIMES."
1226   (org-columns--summary-apply-times #'min times))
1227
1228 (defun org-columns--summary-max-time (times _)
1229   "Compute the maximum time among TIMES."
1230   (org-columns--summary-apply-times #'max times))
1231
1232 (defun org-columns--summary-mean-time (times _)
1233   "Compute the mean time among TIMES."
1234   (org-columns--summary-apply-times
1235    (lambda (&rest values) (/ (apply #'+ values) (float (length values))))
1236    times))
1237
1238 (defun org-columns--summary-min-age (ages _)
1239   "Compute the minimum time among TIMES."
1240   (format-seconds
1241    "%dd %.2hh %mm %ss"
1242    (apply #'min (mapcar #'org-columns--age-to-seconds ages))))
1243
1244 (defun org-columns--summary-max-age (ages _)
1245   "Compute the maximum time among TIMES."
1246   (format-seconds
1247    "%dd %.2hh %mm %ss"
1248    (apply #'max (mapcar #'org-columns--age-to-seconds ages))))
1249
1250 (defun org-columns--summary-mean-age (ages _)
1251   "Compute the minimum time among TIMES."
1252   (format-seconds
1253    "%dd %.2hh %mm %ss"
1254    (/ (apply #'+ (mapcar #'org-columns--age-to-seconds ages))
1255       (float (length ages)))))
1256
1257 (defun org-columns--summary-estimate (estimates printf)
1258   "Combine a list of estimates, using mean and variance.
1259 The mean and variance of the result will be the sum of the means
1260 and variances (respectively) of the individual estimates."
1261   (let ((mean 0)
1262         (var 0))
1263     (dolist (e estimates)
1264       (pcase (mapcar #'string-to-number (split-string e "-"))
1265         (`(,low ,high)
1266          (let ((m (/ (+ low high) 2.0)))
1267            (cl-incf mean m)
1268            (cl-incf var (- (/ (+ (* low low) (* high high)) 2.0) (* m m)))))
1269         (`(,value) (cl-incf mean value))))
1270     (let ((sd (sqrt var)))
1271       (format "%s-%s"
1272               (format (or printf "%.0f") (- mean sd))
1273               (format (or printf "%.0f") (+ mean sd))))))
1274
1275
1276 \f
1277 ;;; Dynamic block for Column view
1278
1279 (defun org-columns--capture-view (maxlevel skip-empty format local)
1280   "Get the column view of the current buffer.
1281
1282 MAXLEVEL sets the level limit.  SKIP-EMPTY tells whether to skip
1283 empty rows, an empty row being one where all the column view
1284 specifiers but ITEM are empty.  FORMAT is a format string for
1285 columns, or nil.  When LOCAL is non-nil, only capture headings in
1286 current subtree.
1287
1288 This function returns a list containing the title row and all
1289 other rows.  Each row is a list of fields, as strings, or
1290 `hline'."
1291   (org-columns (not local) format)
1292   (goto-char org-columns-top-level-marker)
1293   (let ((columns (length org-columns-current-fmt-compiled))
1294         (has-item (assoc-string "ITEM" org-columns-current-fmt-compiled t))
1295         table)
1296     (org-map-entries
1297      (lambda ()
1298        (when (get-char-property (point) 'org-columns-key)
1299          (let (row)
1300            (dotimes (i columns)
1301              (let* ((col (+ (line-beginning-position) i))
1302                     (p (get-char-property col 'org-columns-key)))
1303                (push (org-quote-vert
1304                       (get-char-property col
1305                                          (if (string= (upcase p) "ITEM")
1306                                              'org-columns-value
1307                                            'org-columns-value-modified)))
1308                      row)))
1309            (unless (and skip-empty
1310                         (let ((r (delete-dups (remove "" row))))
1311                           (or (null r) (and has-item (= (length r) 1)))))
1312              (push (cons (org-reduced-level (org-current-level)) (nreverse row))
1313                    table)))))
1314      (and maxlevel (format "LEVEL<=%d" maxlevel))
1315      (and local 'tree)
1316      'archive 'comment)
1317     (org-columns-quit)
1318     ;; Add column titles and a horizontal rule in front of the table.
1319     (cons (mapcar #'cadr org-columns-current-fmt-compiled)
1320           (cons 'hline (nreverse table)))))
1321
1322 (defun org-columns--clean-item (item)
1323   "Remove sensitive contents from string ITEM.
1324 This includes objects that may not be duplicated within
1325 a document, e.g., a target, or those forbidden in tables, e.g.,
1326 an inline src-block."
1327   (let ((data (org-element-parse-secondary-string
1328                item (org-element-restriction 'headline))))
1329     (org-element-map data
1330         '(footnote-reference inline-babel-call inline-src-block target
1331                              radio-target statistics-cookie)
1332       #'org-element-extract-element)
1333     (org-no-properties (org-element-interpret-data data))))
1334
1335 ;;;###autoload
1336 (defun org-dblock-write:columnview (params)
1337   "Write the column view table.
1338 PARAMS is a property list of parameters:
1339
1340 :id       the :ID: property of the entry where the columns view
1341           should be built.  When the symbol `local', call locally.
1342           When `global' call column view with the cursor at the beginning
1343           of the buffer (usually this means that the whole buffer switches
1344           to column view).  When \"file:path/to/file.org\", invoke column
1345           view at the start of that file.  Otherwise, the ID is located
1346           using `org-id-find'.
1347 :hlines   When t, insert a hline before each item.  When a number, insert
1348           a hline before each level <= that number.
1349 :indent   When non-nil, indent each ITEM field according to its level.
1350 :vlines   When t, make each column a colgroup to enforce vertical lines.
1351 :maxlevel When set to a number, don't capture headlines below this level.
1352 :skip-empty-rows
1353           When t, skip rows where all specifiers other than ITEM are empty.
1354 :width    apply widths specified in columns format using <N> specifiers.
1355 :format   When non-nil, specify the column view format to use."
1356   (let ((table
1357          (let ((id (plist-get params :id))
1358                view-file view-pos)
1359            (pcase id
1360              (`global nil)
1361              ((or `local `nil) (setq view-pos (point)))
1362              ((and (let id-string (format "%s" id))
1363                    (guard (string-match "^file:\\(.*\\)" id-string)))
1364               (setq view-file (match-string-no-properties 1 id-string))
1365               (unless (file-exists-p view-file)
1366                 (user-error "No such file: %S" id-string)))
1367              ((and (let idpos (org-find-entry-with-id id)) idpos)
1368               (setq view-pos idpos))
1369              ((let `(,filename . ,position) (org-id-find id))
1370               (setq view-file filename)
1371               (setq view-pos position))
1372              (_ (user-error "Cannot find entry with :ID: %s" id)))
1373            (with-current-buffer (if view-file (get-file-buffer view-file)
1374                                   (current-buffer))
1375              (org-with-wide-buffer
1376               (when view-pos (goto-char view-pos))
1377               (org-columns--capture-view (plist-get params :maxlevel)
1378                                          (plist-get params :skip-empty-rows)
1379                                          (plist-get params :format)
1380                                          view-pos))))))
1381     (when table
1382       ;; Prune level information from the table.  Also normalize
1383       ;; headings: remove stars, add indentation entities, if
1384       ;; required, and possibly precede some of them with a horizontal
1385       ;; rule.
1386       (let ((item-index
1387              (let ((p (assoc-string "ITEM" org-columns-current-fmt-compiled t)))
1388                (and p (cl-position p
1389                                    org-columns-current-fmt-compiled
1390                                    :test #'equal))))
1391             (hlines (plist-get params :hlines))
1392             (indent (plist-get params :indent))
1393             new-table)
1394         ;; Copy header and first rule.
1395         (push (pop table) new-table)
1396         (push (pop table) new-table)
1397         (dolist (row table (setq table (nreverse new-table)))
1398           (let ((level (car row)))
1399             (when (and (not (eq (car new-table) 'hline))
1400                        (or (eq hlines t)
1401                            (and (numberp hlines) (<= level hlines))))
1402               (push 'hline new-table))
1403             (when item-index
1404               (let ((item (org-columns--clean-item (nth item-index (cdr row)))))
1405                 (setf (nth item-index (cdr row))
1406                       (if (and indent (> level 1))
1407                           (concat "\\_" (make-string (* 2 (1- level)) ?\s) item)
1408                         item))))
1409             (push (cdr row) new-table))))
1410       (when (plist-get params :width)
1411         (setq table
1412               (append table
1413                       (list
1414                        (mapcar (lambda (spec)
1415                                  (let ((w (nth 2 spec)))
1416                                    (if w (format "<%d>" (max 3 w)) "")))
1417                                org-columns-current-fmt-compiled)))))
1418       (when (plist-get params :vlines)
1419         (setq table
1420               (let ((size (length org-columns-current-fmt-compiled)))
1421                 (append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x)))
1422                                 table)
1423                         (list (cons "/" (make-list size "<>")))))))
1424       (let ((content-lines (org-split-string (plist-get params :content) "\n"))
1425             recalc)
1426         ;; Insert affiliated keywords before the table.
1427         (when content-lines
1428           (while (string-match-p "\\`[ \t]*#\\+" (car content-lines))
1429             (insert (pop content-lines) "\n")))
1430         (save-excursion
1431           ;; Insert table at point.
1432           (insert
1433            (mapconcat (lambda (row)
1434                         (if (eq row 'hline) "|-|"
1435                           (format "|%s|" (mapconcat #'identity row "|"))))
1436                       table
1437                       "\n"))
1438           ;; Insert TBLFM lines following table.
1439           (let ((case-fold-search t))
1440             (dolist (line content-lines)
1441               (when (string-match-p "\\`[ \t]*#\\+TBLFM:" line)
1442                 (insert "\n" line)
1443                 (unless recalc (setq recalc t))))))
1444         (when recalc (org-table-recalculate 'all t))
1445         (org-table-align)))))
1446
1447 ;;;###autoload
1448 (defun org-columns-insert-dblock ()
1449   "Create a dynamic block capturing a column view table."
1450   (interactive)
1451   (let ((id (completing-read
1452              "Capture columns (local, global, entry with :ID: property) [local]: "
1453              (append '(("global") ("local"))
1454                      (mapcar #'list (org-property-values "ID"))))))
1455     (org-create-dblock
1456      (list :name "columnview"
1457            :hlines 1
1458            :id (cond ((string= id "global") 'global)
1459                      ((member id '("" "local")) 'local)
1460                      (id)))))
1461   (org-update-dblock))
1462
1463 (define-obsolete-function-alias 'org-insert-columns-dblock
1464   'org-columns-insert-dblock "Org 9.0")
1465
1466
1467 \f
1468 ;;; Column view in the agenda
1469
1470 ;;;###autoload
1471 (defun org-agenda-columns ()
1472   "Turn on or update column view in the agenda."
1473   (interactive)
1474   (org-columns-remove-overlays)
1475   (move-marker org-columns-begin-marker (point))
1476   (let ((org-columns--time (float-time (current-time)))
1477         (fmt
1478          (cond
1479           ((org-bound-and-true-p org-agenda-overriding-columns-format))
1480           ((let ((m (org-get-at-bol 'org-hd-marker)))
1481              (and m
1482                   (or (org-entry-get m "COLUMNS" t)
1483                       (with-current-buffer (marker-buffer m)
1484                         org-columns-default-format)))))
1485           ((and (local-variable-p 'org-columns-current-fmt)
1486                 org-columns-current-fmt))
1487           ((let ((m (next-single-property-change (point-min) 'org-hd-marker)))
1488              (and m
1489                   (let ((m (get-text-property m 'org-hd-marker)))
1490                     (or (org-entry-get m "COLUMNS" t)
1491                         (with-current-buffer (marker-buffer m)
1492                           org-columns-default-format))))))
1493           (t org-columns-default-format))))
1494     (setq-local org-columns-current-fmt fmt)
1495     (org-columns-compile-format fmt)
1496     (when org-agenda-columns-compute-summary-properties
1497       (org-agenda-colview-compute org-columns-current-fmt-compiled))
1498     (save-excursion
1499       ;; Collect properties for each headline in current view.
1500       (goto-char (point-min))
1501       (let (cache)
1502         (while (not (eobp))
1503           (let ((m (or (org-get-at-bol 'org-hd-marker)
1504                        (org-get-at-bol 'org-marker))))
1505             (when m
1506               (push (cons (line-beginning-position)
1507                           (org-with-point-at m
1508                             (org-columns--collect-values 'agenda)))
1509                     cache)))
1510           (forward-line))
1511         (when cache
1512           (setq-local org-columns-current-maxwidths
1513                       (org-columns--autowidth-alist cache))
1514           (org-columns--display-here-title)
1515           (when (setq-local org-columns-flyspell-was-active
1516                             (org-bound-and-true-p flyspell-mode))
1517             (flyspell-mode 0))
1518           (dolist (entry cache)
1519             (goto-char (car entry))
1520             (org-columns--display-here (cdr entry)))
1521           (when org-agenda-columns-show-summaries
1522             (org-agenda-colview-summarize cache)))))))
1523
1524 (defun org-agenda-colview-summarize (cache)
1525   "Summarize the summarizable columns in column view in the agenda.
1526 This will add overlays to the date lines, to show the summary for each day."
1527   (let ((fmt (mapcar
1528               (lambda (spec)
1529                 (pcase spec
1530                   (`(,property ,title ,width . ,_)
1531                    (if (member-ignore-case property '("CLOCKSUM" "CLOCKSUM_T"))
1532                        (let ((summarize (org-columns--summarize ":")))
1533                          (list property title width ":" nil summarize))
1534                      spec))))
1535               org-columns-current-fmt-compiled))
1536         entries)
1537     ;; Ensure there's at least one summation column.
1538     (when (cl-some (lambda (spec) (nth 3 spec)) fmt)
1539       (goto-char (point-max))
1540       (while (not (bobp))
1541         (when (or (get-text-property (point) 'org-date-line)
1542                   (eq (get-text-property (point) 'face)
1543                       'org-agenda-structure))
1544           ;; OK, this is a date line that should be used.
1545           (let (rest)
1546             (dolist (c cache (setq cache rest))
1547               (if (> (car c) (point))
1548                   (push c entries)
1549                 (push c rest))))
1550           ;; Now ENTRIES contains entries below the current one.
1551           ;; CACHE is the rest.  Compute the summaries for the
1552           ;; properties we want, set nil properties for the rest.
1553           (when (setq entries (mapcar 'cdr entries))
1554             (org-columns--display-here
1555              (mapcar
1556               (lambda (spec)
1557                 (pcase spec
1558                   (`(,(and prop (guard (equal (upcase prop) "ITEM"))) . ,_)
1559                    ;; Replace ITEM with current date.  Preserve
1560                    ;; properties for fontification.
1561                    (let ((date (buffer-substring
1562                                 (line-beginning-position)
1563                                 (line-end-position))))
1564                      (list prop date date)))
1565                   (`(,prop ,_ ,_ nil . ,_)
1566                    (list prop "" ""))
1567                   (`(,prop ,_ ,_ ,_ ,printf ,summarize)
1568                    (let* ((values
1569                            ;; Use real values for summary, not those
1570                            ;; prepared for display.
1571                            (delq nil
1572                                  (mapcar
1573                                   (lambda (entry)
1574                                     (org-string-nw-p
1575                                      (nth 1 (assoc-string prop entry t))))
1576                                   entries)))
1577                           (final (if values (funcall summarize values printf)
1578                                    "")))
1579                      (unless (equal final "")
1580                        (put-text-property 0 (length final) 'face 'bold final))
1581                      (list prop final final)))))
1582               fmt)
1583              'dateline)
1584             (setq-local org-agenda-columns-active t)))
1585         (forward-line -1)))))
1586
1587 (defun org-agenda-colview-compute (fmt)
1588   "Compute the relevant columns in the contributing source buffers."
1589   (let ((files org-agenda-contributing-files)
1590         (org-columns-begin-marker (make-marker))
1591         (org-columns-top-level-marker (make-marker)))
1592     (dolist (f files)
1593       (let ((b (find-buffer-visiting f)))
1594         (with-current-buffer (or (buffer-base-buffer b) b)
1595           (org-with-wide-buffer
1596            (org-with-silent-modifications
1597             (remove-text-properties (point-min) (point-max) '(org-summaries t)))
1598            (goto-char (point-min))
1599            (org-columns-get-format-and-top-level)
1600            (dolist (spec fmt)
1601              (let ((prop (car spec)))
1602                (cond
1603                 ((equal (upcase prop) "CLOCKSUM") (org-clock-sum))
1604                 ((equal (upcase prop) "CLOCKSUM_T") (org-clock-sum-today))
1605                 ((and (nth 3 spec)
1606                       (let ((a (assoc prop org-columns-current-fmt-compiled)))
1607                         (equal (nth 3 a) (nth 3 spec))))
1608                  (org-columns-compute prop)))))))))))
1609
1610
1611 (provide 'org-colview)
1612
1613 ;;; org-colview.el ends here