diff options
Diffstat (limited to 'lisp/org-colview.el')
| -rw-r--r-- | lisp/org-colview.el | 2162 |
1 files changed, 1101 insertions, 1061 deletions
diff --git a/lisp/org-colview.el b/lisp/org-colview.el index eade725..d33f505 100644 --- a/lisp/org-colview.el +++ b/lisp/org-colview.el @@ -1,4 +1,4 @@ -;;; org-colview.el --- Column View in Org-mode +;;; org-colview.el --- Column View in Org -*- lexical-binding: t; -*- ;; Copyright (C) 2004-2016 Free Software Foundation, Inc. @@ -28,42 +28,117 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'cl-lib) (require 'org) -(declare-function org-agenda-redo "org-agenda" ()) +(declare-function org-agenda-redo "org-agenda" (&optional all)) (declare-function org-agenda-do-context-action "org-agenda" ()) (declare-function org-clock-sum-today "org-clock" (&optional headline-filter)) - -(when (featurep 'xemacs) - (error "Do not load this file into XEmacs, use `org-colview-xemacs.el' from the contrib/ directory")) - +(declare-function org-element-extract-element "org-element" (element)) +(declare-function org-element-interpret-data "org-element" (data)) +(declare-function org-element-map "org-element" (data types fun &optional info first-match no-recursion with-affiliated)) +(declare-function org-element-parse-secondary-string "org-element" (string restriction &optional parent)) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-restriction "org-element" (element)) +(declare-function org-element-type "org-element" (element)) + +(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) +(defvar org-inlinetask-min-level) + + +;;; Configuration + +(defcustom org-columns-modify-value-for-display-function nil + "Function that modifies values for display in column view. +For example, it can be used to cut out a certain part from a time stamp. +The function must take 2 arguments: + +column-title The title of the column (*not* the property name) +value The value that should be modified. + +The function should return the value that should be displayed, +or nil if the normal value should be used." + :group 'org-properties + :type '(choice (const nil) (function))) + +(defcustom org-columns-summary-types nil + "Alist between operators and summarize functions. + +Each association follows the pattern (LABEL . SUMMARIZE) where + + LABEL is a string used in #+COLUMNS definition describing the + summary type. It can contain any character but \"}\". It is + case-sensitive. + + SUMMARIZE is a function called with two arguments. The first + argument is a non-empty list of values, as non-empty strings. + The second one is a format string or nil. It has to return + a string summarizing the list of values. + +Note that the return value can become one value for an higher +order summary, so the function is expected to handle its own +output. + +Types defined in this variable take precedence over those defined +in `org-columns-summary-types-default', which see." + :group 'org-properties + :version "25.2" + :package-version '(Org . "9.0") + :type '(alist :key-type (string :tag " Label") + :value-type (function :tag "Summarize"))) + + + ;;; Column View (defvar org-columns-overlays nil "Holds the list of current column overlays.") -(defvar org-columns-current-fmt nil +(defvar org-columns--time 0.0 + "Number of seconds since the epoch, as a floating point number.") + +(defvar-local org-columns-current-fmt nil "Local variable, holds the currently active column format.") -(make-variable-buffer-local 'org-columns-current-fmt) -(defvar org-columns-current-fmt-compiled nil + +(defvar-local org-columns-current-fmt-compiled nil "Local variable, holds the currently active column format. This is the compiled version of the format.") -(make-variable-buffer-local 'org-columns-current-fmt-compiled) -(defvar org-columns-current-widths nil - "Loval variable, holds the currently widths of fields.") -(make-variable-buffer-local 'org-columns-current-widths) -(defvar org-columns-current-maxwidths nil - "Loval variable, holds the currently active maximum column widths.") -(make-variable-buffer-local 'org-columns-current-maxwidths) + +(defvar-local org-columns-current-maxwidths nil + "Currently active maximum column widths, as a vector.") + (defvar org-columns-begin-marker (make-marker) "Points to the position where last a column creation command was called.") + (defvar org-columns-top-level-marker (make-marker) "Points to the position where current columns region starts.") (defvar org-columns-map (make-sparse-keymap) "The keymap valid in column display.") +(defconst org-columns-summary-types-default + '(("+" . org-columns--summary-sum) + ("$" . org-columns--summary-currencies) + ("X" . org-columns--summary-checkbox) + ("X/" . org-columns--summary-checkbox-count) + ("X%" . org-columns--summary-checkbox-percent) + ("max" . org-columns--summary-max) + ("mean" . org-columns--summary-mean) + ("min" . org-columns--summary-min) + (":" . org-columns--summary-sum-times) + (":max" . org-columns--summary-max-time) + (":mean" . org-columns--summary-mean-time) + (":min" . org-columns--summary-min-time) + ("@max" . org-columns--summary-max-age) + ("@mean" . org-columns--summary-mean-age) + ("@min" . org-columns--summary-min-age) + ("est+" . org-columns--summary-estimate)) + "Map operators to summarize functions. +See `org-columns-summary-types' for details.") + (defun org-columns-content () "Switch to contents view while in columns view." (interactive) @@ -146,12 +221,77 @@ 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 (spec value) + "Return displayed value for specification SPEC in current entry. -(defun org-columns-new-overlay (beg end &optional string face) +SPEC is a column format specification as stored in +`org-columns-current-fmt-compiled'. VALUE is the real value to +display, as a string." + (cond + ((and (functionp org-columns-modify-value-for-display-function) + (funcall org-columns-modify-value-for-display-function + (nth 1 spec) + value))) + ((equal (car spec) "ITEM") + (concat (make-string (1- (org-current-level)) + (if org-hide-leading-stars ?\s ?*)) + "* " + (org-columns-compact-links value))) + (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 (SPEC VALUE DISPLAYED) suitable for +`org-columns--display-here'. + +This function assumes `org-columns-current-fmt-compiled' is +initialized." + (let ((summaries (get-text-property (point) 'org-summaries))) + (mapcar + (lambda (spec) + (pcase spec + (`(,p . ,_) + (let* ((v (or (cdr (assoc spec summaries)) + (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= p (upcase org-effort-property)) + (get-text-property (point) 'duration) + (propertize + (org-minutes-to-clocksum-string + (get-text-property (point) 'duration)) + 'face 'org-warning)) + ""))) + (list spec v (org-columns--displayed-value spec v)))))) + org-columns-current-fmt-compiled))) + +(defun org-columns--set-widths (cache) + "Compute the maximum column widths from the format and CACHE. +This function sets `org-columns-current-maxwidths' as a vector of +integers greater than 0." + (setq org-columns-current-maxwidths + (apply #'vector + (mapcar + (lambda (spec) + (pcase spec + (`(,_ ,_ ,(and width (pred wholenump)) . ,_) width) + (`(,_ ,name . ,_) + ;; No width is specified in the columns format. + ;; Compute it by checking all possible values for + ;; PROPERTY. + (let ((width (length name))) + (dolist (entry cache width) + (let ((value (nth 2 (assoc spec (cdr entry))))) + (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." (let ((ov (make-overlay beg end))) (overlay-put ov 'face (or face 'secondary-selection)) @@ -159,9 +299,35 @@ 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--summarize (operator) + "Return summary function associated to string OPERATOR." + (if (not operator) nil + (cdr (or (assoc operator org-columns-summary-types) + (assoc operator org-columns-summary-types-default) + (error "Unknown %S operator" operator))))) + +(defun org-columns--overlay-text (value fmt width property original) + "Return text " + (format fmt + (let ((v (org-columns-add-ellipses value width))) + (pcase 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))))) + +(defun org-columns--display-here (columns &optional dateline) + "Overlay the current line with column display. +COLUMNS is an alist (SPEC 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 "\\(\\**\\)\\(\\* \\)") @@ -174,14 +340,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. @@ -192,66 +351,34 @@ 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))) + (let ((i 0) + (last (1- (length columns)))) + (dolist (column columns) + (pcase column + (`(,spec ,original ,value) + (let* ((property (car spec)) + (width (aref org-columns-current-maxwidths i)) + (fmt (format (if (= i last) "%%-%d.%ds |" + "%%-%d.%ds | ") + width width)) + (ov (org-columns--new-overlay + (point) (1+ (point)) + (org-columns--overlay-text + value fmt width property original) + (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)))) + (cl-incf i))) ;; Make the rest of the line disappear. - (let ((ov (org-columns-new-overlay (point) (line-end-position)))) + (let ((ov (org-columns--new-overlay (point) (line-end-position)))) (overlay-put ov 'invisible t) (overlay-put ov 'keymap org-columns-map) (overlay-put ov 'line-prefix "") @@ -267,7 +394,7 @@ This is the compiled version of the format.") (line-beginning-position 2) 'read-only (substitute-command-keys - "Type \\<org-columns-map>\\[org-columns-edit-value] \ + "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ to edit property"))))))) (defun org-columns-add-ellipses (string width) @@ -293,36 +420,27 @@ 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))) - (org-set-local 'org-previous-header-line-format header-line-format) - (org-set-local 'org-columns-current-widths (nreverse widths)) - (setq org-columns-full-header-line-format title) + (let ((title "") + (i 0)) + (dolist (column org-columns-current-fmt-compiled) + (pcase column + (`(,property ,name . ,_) + (let* ((width (aref org-columns-current-maxwidths i)) + (fmt (format "%%-%d.%ds | " width width))) + (setq title (concat title (format fmt (or name property))))))) + (cl-incf i)) + (setq-local org-previous-header-line-format header-line-format) + (setq org-columns-full-header-line-format + (concat + (org-add-props " " nil 'display '(space :align-to 0)) + (org-add-props (substring title 0 -1) nil 'face 'org-column-title))) (setq org-columns-previous-hscroll -1) - ; (org-columns-hscoll-title) - (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local))) + (add-hook 'post-command-hook 'org-columns-hscroll-title nil 'local))) -(defun org-columns-hscoll-title () +(defun org-columns-hscroll-title () "Set the `header-line-format' so that it scrolls along with the table." (sit-for .0001) ; need to force a redisplay to update window-hscroll (when (not (= (window-hscroll) org-columns-previous-hscroll)) @@ -345,7 +463,7 @@ for the duration of the command.") (when (local-variable-p 'org-previous-header-line-format) (setq header-line-format org-previous-header-line-format) (kill-local-variable 'org-previous-header-line-format) - (remove-hook 'post-command-hook 'org-columns-hscoll-title 'local)) + (remove-hook 'post-command-hook 'org-columns-hscroll-title 'local)) (move-marker org-columns-begin-marker nil) (move-marker org-columns-top-level-marker nil) (org-with-silent-modifications @@ -381,25 +499,26 @@ for the duration of the command.") (org-columns-remove-overlays) (let ((inhibit-read-only t)) (remove-text-properties (point-min) (point-max) '(read-only t)))) - (when (eq major-mode 'org-agenda-mode) + (if (not (eq major-mode 'org-agenda-mode)) + (setq org-columns-current-fmt nil) (setq org-agenda-columns-active nil) (message "Modification not yet reflected in Agenda buffer, use `r' to refresh"))) (defun org-columns-check-computed () - "Check if this column value is computed. -If yes, throw an error indicating that changing it does not make sense." - (let ((val (get-char-property (point) 'org-columns-value))) - (when (and (stringp val) - (get-char-property 0 'org-computed val)) - (error "This value is computed from the entry's children")))) - -(defun org-columns-todo (&optional arg) + "Throw an error if current column value is computed." + (let ((spec (nth (current-column) org-columns-current-fmt-compiled))) + (and + (nth 3 spec) + (assoc spec (get-text-property (line-beginning-position) 'org-summaries)) + (error "This value is computed from the entry's children")))) + +(defun org-columns-todo (&optional _arg) "Change the TODO state during column view." (interactive "P") (org-columns-edit-value "TODO")) -(defun org-columns-set-tags-or-toggle (&optional arg) +(defun org-columns-set-tags-or-toggle (&optional _arg) "Toggle checkbox at point, or set tags for current headline." (interactive "P") (if (string-match "\\`\\[[ xX-]\\]\\'" @@ -417,107 +536,76 @@ Where possible, use the standard interface for changing this line." (interactive) (org-columns-check-computed) (let* ((col (current-column)) + (bol (line-beginning-position)) + (eol (line-end-position)) + (pom (or (get-text-property bol 'org-hd-marker) (point))) (key (or key (get-char-property (point) 'org-columns-key))) - (value (get-char-property (point) 'org-columns-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))) - (org-columns-time (time-to-number-of-days (current-time))) - nval eval allowed) + (org-columns--time (float-time (current-time))) + (action + (pcase key + ("CLOCKSUM" + (error "This special column cannot be edited")) + ("ITEM" + (lambda () (org-with-point-at pom (org-edit-headline)))) + ("TODO" + (lambda () + (org-with-point-at pom (call-interactively #'org-todo)))) + ("PRIORITY" + (lambda () + (org-with-point-at pom + (call-interactively #'org-priority)))) + ("TAGS" + (lambda () + (org-with-point-at pom + (let ((org-fast-tag-selection-single-key + (if (eq org-fast-tag-selection-single-key 'expert) + t + org-fast-tag-selection-single-key))) + (call-interactively #'org-set-tags))))) + ("DEADLINE" + (lambda () + (org-with-point-at pom (call-interactively #'org-deadline)))) + ("SCHEDULED" + (lambda () + (org-with-point-at pom (call-interactively #'org-schedule)))) + ("BEAMER_ENV" + (lambda () + (org-with-point-at pom + (call-interactively #'org-beamer-select-environment)))) + (_ + (let* ((allowed (org-property-get-allowed-values pom key 'table)) + (value (get-char-property (point) 'org-columns-value)) + (nval (org-trim + (if (null allowed) (read-string "Edit: " value) + (completing-read + "Value: " allowed nil + (not (get-text-property + 0 'org-unrestricted (caar allowed)))))))) + (and (not (equal nval value)) + (lambda () (org-entry-put pom key nval)))))))) (cond - ((equal key "CLOCKSUM") - (error "This special column cannot be edited")) - ((equal key "ITEM") - (setq eval '(org-with-point-at pom - (org-edit-headline)))) - ((equal key "TODO") - (setq eval '(org-with-point-at - pom - (call-interactively 'org-todo)))) - ((equal key "PRIORITY") - (setq eval '(org-with-point-at pom - (call-interactively 'org-priority)))) - ((equal key "TAGS") - (setq eval '(org-with-point-at pom - (let ((org-fast-tag-selection-single-key - (if (eq org-fast-tag-selection-single-key 'expert) - t org-fast-tag-selection-single-key))) - (call-interactively 'org-set-tags))))) - ((equal key "DEADLINE") - (setq eval '(org-with-point-at pom - (call-interactively 'org-deadline)))) - ((equal key "SCHEDULED") - (setq eval '(org-with-point-at pom - (call-interactively 'org-schedule)))) - ((equal key "BEAMER_env") - (setq eval '(org-with-point-at pom - (call-interactively 'org-beamer-select-environment)))) + ((null action)) + ((eq major-mode 'org-agenda-mode) + (org-columns--call action) + ;; The following let preserves the current format, and makes + ;; sure that in only a single file things need to be updated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) (t - (setq allowed (org-property-get-allowed-values pom key 'table)) - (if allowed - (setq nval (org-icompleting-read - "Value: " allowed nil - (not (get-text-property 0 'org-unrestricted - (caar allowed))))) - (setq nval (read-string "Edit: " value))) - (setq nval (org-trim nval)) - (when (not (equal nval value)) - (setq eval '(org-entry-put pom key nval))))) - (when eval - - (cond - ((equal major-mode 'org-agenda-mode) - (org-columns-eval eval) - ;; The following let preserves the current format, and makes sure - ;; that in only a single file things need to be updated. - (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) - (buffer (marker-buffer pom)) - (org-agenda-contributing-files - (list (with-current-buffer buffer - (buffer-file-name (buffer-base-buffer)))))) - (org-agenda-columns))) - (t - (let ((inhibit-read-only t)) - (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-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))))))) - -(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." - (org-back-to-heading) - (when (looking-at org-todo-line-regexp) - (let ((pos (point)) - (pre (buffer-substring (match-beginning 0) (match-beginning 3))) - (txt (match-string 3)) - (post "") - txt2) - (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt) - (setq post (match-string 0 txt) - txt (substring txt 0 (match-beginning 0)))) - (setq txt2 (read-string "Edit: " txt)) - (when (not (equal txt txt2)) - (goto-char pos) - (insert pre txt2 post) - (delete-region (point) (point-at-eol)) - (org-set-tags nil t))))) + (let ((inhibit-read-only t)) + (org-with-silent-modifications + (remove-text-properties (max (point-min) (1- bol)) eol '(read-only t))) + (org-columns--call action)) + ;; Some properties can modify headline (e.g., "TODO"), and + ;; possible shuffle overlays. Make sure they are still all at + ;; the right place on the current line. + (let ((org-columns-inhibit-recalculation)) (org-columns-redo)) + (org-columns-update key) + (org-move-to-column col))))) (defun org-columns-edit-allowed () "Edit the list of allowed values for the current property." @@ -540,15 +628,15 @@ Where possible, use the standard interface for changing this line." (t pom)) key1 nval))) -(defun org-columns-eval (form) - (let (hidep) - (save-excursion - (beginning-of-line 1) - ;; `next-line' is needed here, because it skips invisible line. - (condition-case nil (org-no-warnings (next-line 1)) (error nil)) - (setq hidep (org-at-heading-p 1))) - (eval form) - (and hidep (outline-hide-entry)))) +(defun org-columns--call (fun) + "Call function FUN while preserving heading visibility. +FUN is a function called with no argument." + (let ((hide-body (and (/= (line-end-position) (point-max)) + (save-excursion + (move-beginning-of-line 2) + (org-at-heading-p t))))) + (unwind-protect (funcall fun) + (when hide-body (outline-hide-entry))))) (defun org-columns-previous-allowed-value () "Switch to the previous allowed value for this column." @@ -561,74 +649,57 @@ When PREVIOUS is set, go to the previous value. When NTH is an integer, select that value." (interactive) (org-columns-check-computed) - (let* ((col (current-column)) + (let* ((column (current-column)) (key (get-char-property (point) 'org-columns-key)) (value (get-char-property (point) 'org-columns-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 - org-columns-current-fmt-compiled - t)) - '(checkbox checkbox-n-of-m checkbox-percent)) - '("[ ]" "[X]")) - (org-colview-construct-allowed-dates value))) - nval) - (when (integerp nth) - (setq nth (1- nth)) - (if (= nth -1) (setq nth 9))) - (when (equal key "ITEM") - (error "Cannot edit item headline from here")) + (pom (or (get-text-property (line-beginning-position) 'org-hd-marker) + (point))) + (allowed + (let ((all + (or (org-property-get-allowed-values pom key) + (pcase (nth column org-columns-current-fmt-compiled) + (`(,_ ,_ ,_ ,(or "X" "X/" "X%") ,_) '("[ ]" "[X]"))) + (org-colview-construct-allowed-dates value)))) + (if previous (reverse all) all)))) + (when (equal key "ITEM") (error "Cannot edit item headline from here")) (unless (or allowed (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM"))) (error "Allowed values for this property have not been defined")) - (if (member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")) - (setq nval (if previous 'earlier 'later)) - (if previous (setq allowed (reverse allowed))) + (let* ((l (length allowed)) + (new + (cond + ((member key '("SCHEDULED" "DEADLINE" "CLOCKSUM")) + (if previous 'earlier 'later)) + ((integerp nth) + (when (> (abs nth) l) + (user-error "Only %d allowed values for property `%s'" l key)) + (nth (mod (1- nth) l) allowed)) + ((member value allowed) + (when (= l 1) (error "Only one allowed value for this property")) + (or (nth 1 (member value allowed)) (car allowed))) + (t (car allowed)))) + (action (lambda () (org-entry-put pom key new)))) (cond - (nth - (setq nval (nth nth allowed)) - (if (not nval) - (error "There are only %d allowed values for property `%s'" - (length allowed) key))) - ((member value allowed) - (setq nval (or (car (cdr (member value allowed))) - (car allowed))) - (if (equal nval value) - (error "Only one allowed value for this property"))) - (t (setq nval (car allowed))))) - (cond - ((equal major-mode 'org-agenda-mode) - (org-columns-eval `(org-entry-put ,pom ,key ,nval)) - ;; The following let preserves the current format, and makes sure - ;; that in only a single file things need to be updated. - (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) - (buffer (marker-buffer pom)) - (org-agenda-contributing-files - (list (with-current-buffer buffer - (buffer-file-name (buffer-base-buffer)))))) - (org-agenda-columns))) - (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-move-to-column col) - (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t)) - (org-columns-update key)))))) + ((eq major-mode 'org-agenda-mode) + (org-columns--call action) + ;; The following let preserves the current format, and makes + ;; sure that in only a single file things need to be updated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) + (t + (let ((inhibit-read-only t)) + (remove-text-properties (line-end-position 0) (line-end-position) + '(read-only t)) + (org-columns--call action)) + ;; Some properties can modify headline (e.g., "TODO"), and + ;; possible shuffle overlays. Make sure they are still all at + ;; the right place on the current line. + (let ((org-columns-inhibit-recalculation)) (org-columns-redo)) + (org-columns-update key) + (org-move-to-column column)))))) (defun org-colview-construct-allowed-dates (s) "Construct a list of three dates around the date in S. @@ -651,13 +722,6 @@ around it." (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) (list time-before time time-after))))) -(defun org-verify-version (task) - (cond - ((eq task 'columns) - (if (or (featurep 'xemacs) - (< emacs-major-version 22)) - (error "Emacs 22 is required for the columns feature"))))) - (defun org-columns-open-link (&optional arg) (interactive "P") (let ((value (get-char-property (point) 'org-columns-value))) @@ -670,14 +734,28 @@ around it." fmt)) (defun org-columns-get-format (&optional fmt-string) + "Return columns format specifications. +When optional argument FMT-STRING is non-nil, use it as the +current specifications. This function also sets +`org-columns-current-fmt-compiled' and +`org-columns-current-fmt'." (interactive) - (let (fmt-as-property fmt) - (when (condition-case nil (org-back-to-heading) (error nil)) - (setq fmt-as-property (org-entry-get nil "COLUMNS" t))) - (setq fmt (or fmt-string fmt-as-property org-columns-default-format)) - (org-set-local 'org-columns-current-fmt fmt) - (org-columns-compile-format fmt) - fmt)) + (let ((format + (or fmt-string + (org-entry-get nil "COLUMNS" t) + (org-with-wide-buffer + (goto-char (point-min)) + (catch :found + (let ((case-fold-search t)) + (while (re-search-forward "^[ \t]*#\\+COLUMNS: .+$" nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (throw :found (org-element-property :value element))))) + nil))) + org-columns-default-format))) + (setq org-columns-current-fmt format) + (org-columns-compile-format format) + format)) (defun org-columns-goto-top-level () "Move to the beginning of the column view area. @@ -690,162 +768,130 @@ Also sets `org-columns-top-level-marker' to the new position." (t (org-back-to-heading) (point)))))) ;;;###autoload -(defun org-columns (&optional columns-fmt-string) - "Turn on column view on an org-mode file. +(defun org-columns (&optional global columns-fmt-string) + "Turn on column view on an Org mode file. + +Column view applies to the whole buffer if point is before the +first headline. Otherwise, it applies to the first ancestor +setting \"COLUMNS\" property. If there is none, it defaults to +the current headline. With a `\\[universal-argument]' prefix \ +argument, turn on column +view for the whole buffer unconditionally. + When COLUMNS-FMT-STRING is non-nil, use it as the column format." - (interactive) - (org-verify-version 'columns) + (interactive "P") (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) (org-columns-goto-top-level) ;; Initialize `org-columns-current-fmt' and ;; `org-columns-current-fmt-compiled'. - (let ((org-columns-time (time-to-number-of-days (current-time)))) - (org-columns-get-format columns-fmt-string)) - (unless org-columns-inhibit-recalculation (org-columns-compute-all)) - (save-excursion - (save-restriction - (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) - (org-clock-sum)) - (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled) - (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 (org-columns--value p (point)))) - column-names))) - nil nil (and org-columns-skip-archived-trees 'archive)))) - (when cache - (org-set-local 'org-columns-current-maxwidths - (org-columns-get-autowidth-alist - org-columns-current-fmt - cache)) - (org-columns-display-here-title) - (when (org-set-local 'org-columns-flyspell-was-active - (org-bound-and-true-p flyspell-mode)) - (flyspell-mode 0)) - (unless (local-variable-p 'org-colview-initial-truncate-line-value) - (org-set-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)))))))) - -(eval-when-compile (defvar org-columns-time)) - -(defvar org-columns-compile-map - '(("none" none +) - (":" add_times +) - ("+" add_numbers +) - ("$" currency +) - ("X" checkbox +) - ("X/" checkbox-n-of-m +) - ("X%" checkbox-percent +) - ("max" max_numbers max) - ("min" min_numbers min) - ("mean" mean_numbers - (lambda (&rest x) (/ (apply '+ x) (float (length x))))) - (":max" max_times max) - (":min" min_times min) - (":mean" mean_times - (lambda (&rest x) (/ (apply '+ x) (float (length x))))) - ("@min" min_age min (lambda (x) (- org-columns-time x))) - ("@max" max_age max (lambda (x) (- org-columns-time x))) - ("@mean" mean_age - (lambda (&rest x) (/ (apply '+ x) (float (length x)))) - (lambda (x) (- org-columns-time x))) - ("est+" estimate org-estimate-combine)) - "Operator <-> format,function,calc map. -Used to compile/uncompile columns format and completing read in -interactive function `org-columns-new'. - -operator string used in #+COLUMNS definition describing the - summary type -format symbol describing summary type selected interactively in - `org-columns-new' and internally in - `org-columns-number-to-string' and - `org-columns-string-to-number' -function called with a list of values as argument to calculate - the summary value -calc function called on every element before summarizing. This is - optional and should only be specified if needed") - -(defun org-columns-new (&optional prop title width op fmt fun &rest rest) - "Insert a new column, to the left of the current column." + (let ((org-columns--time (float-time (current-time)))) + (org-columns-get-format columns-fmt-string) + (unless org-columns-inhibit-recalculation (org-columns-compute-all)) + (save-excursion + (save-restriction + (when (and (not global) (org-at-heading-p)) + (narrow-to-region (point) (org-end-of-subtree t t))) + (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled) + (org-clock-sum)) + (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled) + (org-clock-sum-today)) + (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 + (org-columns--set-widths cache) + (org-columns--display-here-title) + (when (setq-local org-columns-flyspell-was-active + (bound-and-true-p flyspell-mode)) + (flyspell-mode 0)) + (unless (local-variable-p 'org-colview-initial-truncate-line-value) + (setq-local org-colview-initial-truncate-line-value + truncate-lines)) + (setq truncate-lines t) + (dolist (entry cache) + (goto-char (car entry)) + (org-columns--display-here (cdr entry))))))))) + +(defun org-columns-new (&optional spec &rest attributes) + "Insert a new column, to the left of the current column. +Interactively fill attributes for new column. When column format +specification SPEC is provided, edit it instead. + +When optional argument attributes can be a list of columns +specifications attributes to create the new column +non-interactively. See `org-columns-compile-format' for +details." (interactive) - (let ((editp (and prop - (assoc-string prop org-columns-current-fmt-compiled t))) - cell) - (setq prop (org-icompleting-read - "Property: " (mapcar 'list (org-buffer-property-keys t nil t)) - nil nil prop)) - (setq title (read-string (concat "Column title [" prop "]: ") (or title prop))) - (setq width (read-string "Column width: " (if width (number-to-string width)))) - (if (string-match "\\S-" width) - (setq width (string-to-number width)) - (setq width nil)) - (setq fmt (org-icompleting-read - "Summary [none]: " - (mapcar (lambda (x) (list (symbol-name (cadr x)))) - org-columns-compile-map) - nil t)) - (setq fmt (intern fmt) - fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map)))) - (if (eq fmt 'none) (setq fmt nil)) - (if editp - (progn - (setcar editp prop) - (setcdr editp (list title width nil fmt nil fun))) - (setq cell (nthcdr (1- (current-column)) - org-columns-current-fmt-compiled)) - (setcdr cell (cons (list prop title width nil fmt nil - (car fun) (cadr fun)) - (cdr cell)))) + (let ((new (or attributes + (let ((prop + (completing-read + "Property: " + (mapcar #'list (org-buffer-property-keys t nil t)) + nil nil (nth 0 spec)))) + (list prop + (read-string (format "Column title [%s]: " prop) + (nth 1 spec)) + ;; Use `read-string' instead of `read-number' + ;; to allow empty width. + (let ((w (read-string + "Column width: " + (and (nth 2 spec) + (number-to-string (nth 2 spec)))))) + (and (org-string-nw-p w) (string-to-number w))) + (org-string-nw-p + (completing-read + "Summary: " + (delete-dups + (cons '("") ;Allow empty operator. + (mapcar (lambda (x) (list (car x))) + (append + org-columns-summary-types + org-columns-summary-types-default)))) + nil t (nth 3 spec))) + (org-string-nw-p + (read-string "Format: " (nth 4 spec)))))))) + (if spec + (progn (setcar spec (car new)) + (setcdr spec (cdr new))) + (push new (nthcdr (current-column) org-columns-current-fmt-compiled))) (org-columns-store-format) (org-columns-redo))) (defun org-columns-delete () "Delete the column at point from columns view." (interactive) - (let* ((n (current-column)) - (title (nth 1 (nth n org-columns-current-fmt-compiled)))) - (when (y-or-n-p - (format "Are you sure you want to remove column \"%s\"? " title)) + (let ((spec (nth (current-column) org-columns-current-fmt-compiled))) + (when (y-or-n-p (format "Are you sure you want to remove column %S? " + (nth 1 spec))) (setq org-columns-current-fmt-compiled - (delq (nth n org-columns-current-fmt-compiled) - org-columns-current-fmt-compiled)) + (delq spec org-columns-current-fmt-compiled)) (org-columns-store-format) - (org-columns-redo) - (if (>= (current-column) (length org-columns-current-fmt-compiled)) - (backward-char 1))))) + ;; This may leave a now wrong value in a node property. However + ;; updating it may prove counter-intuitive. See comments in + ;; `org-columns-move-right' for details. + (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)) + (when (>= (current-column) (length org-columns-current-fmt-compiled)) + (backward-char))))) (defun org-columns-edit-attributes () "Edit the attributes of the current column." (interactive) - (let* ((n (current-column)) - (info (nth n org-columns-current-fmt-compiled))) - (apply 'org-columns-new info))) + (org-columns-new (nth (current-column) org-columns-current-fmt-compiled))) (defun org-columns-widen (arg) "Make the column wider by ARG characters." (interactive "p") (let* ((n (current-column)) (entry (nth n org-columns-current-fmt-compiled)) - (width (or (nth 2 entry) - (cdr (assoc-string (car entry) - org-columns-current-maxwidths - t))))) + (width (aref org-columns-current-maxwidths n))) (setq width (max 1 (+ width arg))) (setcar (nthcdr 2 entry) width) (org-columns-store-format) - (org-columns-redo))) + (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)))) (defun org-columns-narrow (arg) "Make the column narrower by ARG characters." @@ -864,7 +910,16 @@ calc function called on every element before summarizing. This is (setcar cell (car (cdr cell))) (setcdr cell (cons e (cdr (cdr cell)))) (org-columns-store-format) - (org-columns-redo) + ;; Do not compute again properties, since we're just moving + ;; columns around. It can put a property value a bit off when + ;; switching between an non-computed and a computed value for the + ;; same property, e.g. from "%A %A{+}" to "%A{+} %A". + ;; + ;; In this case, the value needs to be updated since the first + ;; column related to a property determines how its value is + ;; computed. However, (correctly) updating the value could be + ;; surprising, so we leave it as-is nonetheless. + (let ((org-columns-inhibit-recalculation t)) (org-columns-redo)) (forward-char 1))) (defun org-columns-move-left () @@ -878,364 +933,447 @@ calc function called on every element before summarizing. This is (backward-char 1))) (defun org-columns-store-format () - "Store the text version of the current columns format in appropriate place. -This is either in the COLUMNS property of the node starting the current column -display, or in the #+COLUMNS line of the current buffer." - (let (fmt (cnt 0)) - (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled)) - (org-set-local 'org-columns-current-fmt fmt) - (if (marker-position org-columns-top-level-marker) - (save-excursion - (goto-char org-columns-top-level-marker) - (if (and (org-at-heading-p) - (org-entry-get nil "COLUMNS")) - (org-entry-put nil "COLUMNS" fmt) - (goto-char (point-min)) - ;; Overwrite all #+COLUMNS lines.... - (while (re-search-forward "^[ \t]*#\\+COLUMNS:.*" nil t) - (setq cnt (1+ cnt)) - (replace-match (concat "#+COLUMNS: " fmt) t t)) - (unless (> cnt 0) - (goto-char (point-min)) - (or (org-at-heading-p t) (outline-next-heading)) - (let ((inhibit-read-only t)) - (insert-before-markers "#+COLUMNS: " fmt "\n"))) - (org-set-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 - (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (let ((columns org-columns-current-fmt-compiled) - (org-columns-time (time-to-number-of-days (current-time))) - col) - (while (setq col (pop columns)) - (when (nth 3 col) - (save-excursion - (org-columns-compute (car col))))))) + "Store the text version of the current columns format. +The format is stored either in the COLUMNS property of the node +starting the current column display, or in a #+COLUMNS line of +the current buffer." + (let ((fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))) + (setq-local org-columns-current-fmt fmt) + (when (marker-position org-columns-top-level-marker) + (org-with-wide-buffer + (goto-char org-columns-top-level-marker) + (if (and (org-at-heading-p) (org-entry-get nil "COLUMNS")) + (org-entry-put nil "COLUMNS" fmt) + (goto-char (point-min)) + (let ((case-fold-search t)) + ;; Try to replace the first COLUMNS keyword available. + (catch :found + (while (re-search-forward "^[ \t]*#\\+COLUMNS:\\(.*\\)" nil t) + (let ((element (save-match-data (org-element-at-point)))) + (when (and (eq (org-element-type element) 'keyword) + (equal (org-element-property :key element) + "COLUMNS")) + (replace-match (concat " " fmt) t t nil 1) + (throw :found nil)))) + ;; No COLUMNS keyword in the buffer. Insert one at the + ;; beginning, right before the first heading, if any. + (goto-char (point-min)) + (unless (org-at-heading-p t) (outline-next-heading)) + (let ((inhibit-read-only t)) + (insert-before-markers "#+COLUMNS: " fmt "\n")))) + (setq-local org-columns-default-format fmt)))))) (defun org-columns-update (property) "Recompute PROPERTY, and update the columns display for it." (org-columns-compute property) - (let (fmt val pos) - (save-excursion - (mapc (lambda (ov) - (when (equal (overlay-get ov 'org-columns-key) property) - (setq pos (overlay-start ov)) - (goto-char pos) - (when (setq val (cdr (assoc-string - property - (get-text-property - (point-at-bol) 'org-summaries) - t))) - (setq fmt (overlay-get ov 'org-columns-format)) - (overlay-put ov 'org-columns-value val) - (overlay-put ov 'display (format fmt val))))) - org-columns-overlays)))) - -(defvar org-inlinetask-min-level - (if (featurep 'org-inlinetask) org-inlinetask-min-level 15)) - -;;;###autoload -(defun org-columns-compute (property) - "Sum the values of property PROPERTY hierarchically, for the entire buffer." - (interactive) - (let* ((re org-outline-regexp-bol) - (lmax 30) ; Does anyone use deeper levels??? - (lvals (make-vector lmax nil)) - (lflag (make-vector lmax nil)) - (level 0) - (ass (assoc-string property org-columns-current-fmt-compiled t)) - (format (nth 4 ass)) - (printf (nth 5 ass)) - (fun (nth 6 ass)) - (calc (or (nth 7 ass) 'identity)) - (beg org-columns-top-level-marker) - (inminlevel org-inlinetask-min-level) - (last-level org-inlinetask-min-level) - val valflag flag end sumpos sum-alist sum str str1 useval) - (save-excursion - ;; Find the region to compute - (goto-char beg) - (setq end (condition-case nil (org-end-of-subtree t) (error (point-max)))) - (goto-char end) - ;; Walk the tree from the back and do the computations - (while (re-search-backward re beg t) - (setq sumpos (match-beginning 0) - last-level (if (not (or (zerop level) (eq level inminlevel))) - level last-level) - level (org-outline-level) - val (org-entry-get nil property) - valflag (and val (string-match "\\S-" val))) - (cond - ((< level last-level) - ;; Put the sum of lower levels here as a property. If - ;; values are estimate, use an appropriate sum function. - (setq sum (funcall - (if (eq fun 'org-estimate-combine) #'org-estimate-combine - #'+) - (if (and (/= last-level inminlevel) - (aref lvals last-level)) - (apply fun (aref lvals last-level)) 0) - (if (aref lvals inminlevel) - (apply fun (aref lvals inminlevel)) 0)) - flag (or (aref lflag last-level) ; any valid entries from children? - (aref lflag inminlevel)) ; or inline tasks? - str (org-columns-number-to-string sum format printf) - str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold) - useval (if flag str1 (if valflag val "")) - sum-alist (get-text-property sumpos 'org-summaries)) - (let ((old (assoc-string property sum-alist t))) - (if old (setcdr old useval) - (push (cons property useval) sum-alist) - (org-with-silent-modifications - (add-text-properties sumpos (1+ sumpos) - (list 'org-summaries sum-alist))))) - (when (and val (not (equal val (if flag str val)))) - (org-entry-put nil property (if flag str val))) - ;; add current to current level accumulator - (when (or flag valflag) - (push (if flag - sum - (funcall calc (org-columns-string-to-number - (if flag str val) format))) - (aref lvals level)) - (aset lflag level t)) - ;; clear accumulators for deeper levels - (loop for l from (1+ level) to (1- lmax) do - (aset lvals l nil) - (aset lflag l nil))) - ((>= level last-level) - ;; add what we have here to the accumulator for this level - (when valflag - (push (funcall calc (org-columns-string-to-number val format)) - (aref lvals level)) - (aset lflag level t))) - (t (error "This should not happen"))))))) + (org-with-wide-buffer + (let ((p (upcase property))) + (dolist (ov org-columns-overlays) + (let ((key (overlay-get ov 'org-columns-key))) + (when (and key (equal key p) (overlay-start ov)) + (goto-char (overlay-start ov)) + (let* ((spec (nth (current-column) org-columns-current-fmt-compiled)) + (value + (or (cdr (assoc spec + (get-text-property (line-beginning-position) + 'org-summaries))) + (org-entry-get (point) key)))) + (when value + (let ((displayed (org-columns--displayed-value spec value)) + (format (overlay-get ov 'org-columns-format)) + (width + (aref org-columns-current-maxwidths (current-column)))) + (overlay-put ov 'org-columns-value value) + (overlay-put ov 'org-columns-value-modified displayed) + (overlay-put ov + 'display + (org-columns--overlay-text + displayed format width property value))))))))))) (defun org-columns-redo () "Construct the column display again." (interactive) (message "Recomputing columns...") - (let ((line (org-current-line)) - (col (current-column))) - (save-excursion - (if (marker-position org-columns-begin-marker) - (goto-char org-columns-begin-marker)) - (org-columns-remove-overlays) - (if (derived-mode-p 'org-mode) - (call-interactively 'org-columns) - (org-agenda-redo) - (call-interactively 'org-agenda-columns))) - (org-goto-line line) - (move-to-column col)) + (org-with-wide-buffer + (when (marker-position org-columns-begin-marker) + (goto-char org-columns-begin-marker)) + (org-columns-remove-overlays) + (if (derived-mode-p 'org-mode) + ;; Since we already know the columns format, provide it instead + ;; of computing again. + (call-interactively #'org-columns org-columns-current-fmt) + (org-agenda-redo) + (call-interactively #'org-agenda-columns))) (message "Recomputing columns...done")) -(defun org-columns-not-in-agenda () - (if (eq major-mode 'org-agenda-mode) - (error "This command is only allowed in Org-mode buffers"))) - -(defun org-string-to-number (s) - "Convert string to number, and interpret hh:mm:ss." - (if (not (string-match ":" s)) - (string-to-number s) - (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) - (while l - (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) - sum))) - -;;;###autoload -(defun org-columns-number-to-string (n fmt &optional printf) - "Convert a computed column number to a string value, according to FMT." - (cond - ((memq fmt '(estimate)) (org-estimate-print n printf)) - ((not (numberp n)) "") - ((memq fmt '(add_times max_times min_times mean_times)) - (org-hours-to-clocksum-string n)) - ((eq fmt 'checkbox) - (cond ((= n (floor n)) "[X]") - ((> n 1.) "[-]") - (t "[ ]"))) - ((memq fmt '(checkbox-n-of-m checkbox-percent)) - (let* ((n1 (floor n)) (n2 (floor (+ .5 (* 1000000 (- n n1)))))) - (org-nofm-to-completion n1 (+ n2 n1) (eq fmt 'checkbox-percent)))) - (printf (format printf n)) - ((eq fmt 'currency) - (format "%.2f" n)) - ((memq fmt '(min_age max_age mean_age)) - (org-format-time-period n)) - (t (number-to-string n)))) - -(defun org-nofm-to-completion (n m &optional percent) - (if (not percent) - (format "[%d/%d]" n m) - (format "[%d%%]" (round (* 100.0 n) m)))) - - -(defun org-columns-string-to-number (s fmt) - "Convert a column value to a number that can be used for column computing." - (if s - (cond - ((memq fmt '(min_age max_age mean_age)) - (cond ((string= s "") org-columns-time) - ((string-match - "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s" - s) - (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s))) - (string-to-number (match-string 2 s)))) - (string-to-number (match-string 3 s)))) - (string-to-number (match-string 4 s)))) - (t (time-to-number-of-days (apply 'encode-time - (org-parse-time-string s t)))))) - ((string-match ":" s) - (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) - (while l - (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) - sum)) - ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) - (if (equal s "[X]") 1. 0.000001)) - ((memq fmt '(estimate)) (org-string-to-estimate s)) - ((string-match (concat "\\([0-9.]+\\) *\\(" - (regexp-opt (mapcar 'car org-effort-durations)) - "\\)") s) - (setq s (concat "0:" (org-duration-string-to-minutes s t))) - (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) - (while l - (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) - sum)) - (t (string-to-number s))))) - -(defun org-columns-uncompile-format (cfmt) - "Turn the compiled columns format back into a string representation." - (let ((rtn "") e s prop title op op-match width fmt printf fun calc ee map) - (while (setq e (pop cfmt)) - (setq prop (car e) - title (nth 1 e) - width (nth 2 e) - op (nth 3 e) - fmt (nth 4 e) - printf (nth 5 e) - fun (nth 6 e) - calc (nth 7 e)) - (setq map (copy-sequence org-columns-compile-map)) - (while (setq ee (pop map)) - (if (equal fmt (nth 1 ee)) - (setq op (car ee) map nil))) - (if (and op printf) (setq op (concat op ";" printf))) - (if (equal title prop) (setq title nil)) - (setq s (concat "%" (if width (number-to-string width)) - prop - (if title (concat "(" title ")")) - (if op (concat "{" op "}")))) - (setq rtn (concat rtn " " s))) - (org-trim rtn))) +(defun org-columns-uncompile-format (compiled) + "Turn the compiled columns format back into a string representation. +COMPILED is an alist, as returned by +`org-columns-compile-format', which see." + (mapconcat + (lambda (spec) + (pcase spec + (`(,prop ,title ,width ,op ,printf) + (concat "%" + (and width (number-to-string width)) + prop + (and title (not (equal prop title)) (format "(%s)" title)) + (cond ((not op) nil) + (printf (format "{%s;%s}" op printf)) + (t (format "{%s}" op))))))) + compiled " ")) (defun org-columns-compile-format (fmt) "Turn a column format string FMT into an alist of specifications. The alist has one entry for each column in the format. The elements of that list are: -property the property -title the title field for the columns -width the column width in characters, can be nil for automatic -operator the operator if any -format the output format for computed results, derived from operator -printf a printf format for computed values -fun the lisp function to compute summary values, derived from operator -calc function to get values from base elements +property the property name, as an upper-case string +title the title field for the columns, as a string +width the column width in characters, can be nil for automatic width +operator the summary operator, as a string, or nil +printf a printf format for computed values, as a string, or nil This function updates `org-columns-current-fmt-compiled'." - (let ((start 0) width prop title op op-match f printf fun calc) - (setq org-columns-current-fmt-compiled nil) + (setq org-columns-current-fmt-compiled nil) + (let ((start 0)) (while (string-match - (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*") + "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\ +\\(?:{\\([^}]+\\)}\\)?\\s-*" fmt start) - (setq start (match-end 0) - width (match-string 1 fmt) - prop (match-string 2 fmt) - title (or (match-string 3 fmt) prop) - op (match-string 4 fmt) - f nil - printf nil - fun '+ - calc nil) - (if width (setq width (string-to-number width))) - (when (and op (string-match ";" op)) - (setq printf (substring op (match-end 0)) - op (substring op 0 (match-beginning 0)))) - (when (setq op-match (assoc op org-columns-compile-map)) - (setq f (cadr op-match) - fun (caddr op-match) - calc (cadddr op-match))) - (push (list prop title width op f printf fun calc) - org-columns-current-fmt-compiled)) + (setq start (match-end 0)) + (let* ((width (and (match-end 1) (string-to-number (match-string 1 fmt)))) + (prop (match-string-no-properties 2 fmt)) + (title (or (match-string-no-properties 3 fmt) prop)) + (operator (match-string-no-properties 4 fmt))) + (push (if (not operator) (list (upcase prop) title width nil nil) + (let (printf) + (when (string-match ";" operator) + (setq printf (substring operator (match-end 0))) + (setq operator (substring operator 0 (match-beginning 0)))) + (list (upcase prop) title width operator printf))) + org-columns-current-fmt-compiled))) (setq org-columns-current-fmt-compiled (nreverse org-columns-current-fmt-compiled)))) + +;;;; Column View Summary +(defconst org-columns--duration-re + (concat "[0-9.]+ *" (regexp-opt (mapcar #'car org-effort-durations))) + "Regexp matching a duration.") + +(defun org-columns--time-to-seconds (s) + "Turn time string S into a number of seconds. +A time is expressed as HH:MM, HH:MM:SS, or with units defined in +`org-effort-durations'. Plain numbers are considered as hours." + (cond + ((string-match "\\([0-9]+\\):\\([0-9]+\\)\\(?::\\([0-9]+\\)\\)?" s) + (+ (* 3600 (string-to-number (match-string 1 s))) + (* 60 (string-to-number (match-string 2 s))) + (if (match-end 3) (string-to-number (match-string 3 s)) 0))) + ((string-match-p org-columns--duration-re s) + (* 60 (org-duration-string-to-minutes s))) + (t (* 3600 (string-to-number s))))) + +(defun org-columns--age-to-seconds (s) + "Turn age string S into a number of seconds. +An age is either computed from a given time-stamp, or indicated +as days/hours/minutes/seconds." + (cond + ((string-match-p org-ts-regexp s) + (floor + (- org-columns--time + (float-time (apply #'encode-time (org-parse-time-string s)))))) + ;; Match own output for computations in upper levels. + ((string-match "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s" s) + (+ (* 86400 (string-to-number (match-string 1 s))) + (* 3600 (string-to-number (match-string 2 s))) + (* 60 (string-to-number (match-string 3 s))) + (string-to-number (match-string 4 s)))) + (t (user-error "Invalid age: %S" s)))) + +(defun org-columns--summary-apply-times (fun times) + "Apply FUN to time values TIMES. +If TIMES contains any time value expressed as a duration, return +the result as a duration. If it contains any H:M:S, use that +format instead. Otherwise, use H:M format." + (let* ((hms-flag nil) + (duration-flag nil) + (seconds + (apply fun + (mapcar + (lambda (time) + (cond + (duration-flag) + ((string-match-p org-columns--duration-re time) + (setq duration-flag t)) + (hms-flag) + ((string-match-p "\\`[0-9]+:[0-9]+:[0-9]+\\'" time) + (setq hms-flag t))) + (org-columns--time-to-seconds time)) + times)))) + (cond (duration-flag (org-minutes-to-clocksum-string (/ seconds 60.0))) + (hms-flag (format-seconds "%h:%.2m:%.2s" seconds)) + (t (format-seconds "%h:%.2m" seconds))))) + +(defun org-columns--compute-spec (spec &optional update) + "Update tree according to SPEC. +SPEC is a column format specification. When optional argument +UPDATE is non-nil, summarized values can replace existing ones in +properties drawers." + (let* ((lmax (if (bound-and-true-p org-inlinetask-min-level) + org-inlinetask-min-level + 29)) ;Hard-code deepest level. + (lvals (make-vector (1+ lmax) nil)) + (level 0) + (inminlevel lmax) + (last-level lmax) + (property (car spec)) + (printf (nth 4 spec)) + (summarize (org-columns--summarize (nth 3 spec)))) + (org-with-wide-buffer + ;; Find the region to compute. + (goto-char org-columns-top-level-marker) + (goto-char (condition-case nil (org-end-of-subtree t) (error (point-max)))) + ;; Walk the tree from the back and do the computations. + (while (re-search-backward + org-outline-regexp-bol org-columns-top-level-marker t) + (unless (or (= level 0) (eq level inminlevel)) + (setq last-level level)) + (setq level (org-reduced-level (org-outline-level))) + (let* ((pos (match-beginning 0)) + (value (org-entry-get nil property)) + (value-set (org-string-nw-p value))) + (cond + ((< level last-level) + ;; Collect values from lower levels and inline tasks here + ;; and summarize them using SUMMARIZE. Store them in text + ;; property `org-summaries', in alist whose key is SPEC. + (let* ((summary + (and summarize + (let ((values (append (and (/= last-level inminlevel) + (aref lvals last-level)) + (aref lvals inminlevel)))) + (and values (funcall summarize values printf)))))) + ;; Leaf values are not summaries: do not mark them. + (when summary + (let* ((summaries-alist (get-text-property pos 'org-summaries)) + (old (assoc spec summaries-alist))) + (if old (setcdr old summary) + (push (cons spec summary) summaries-alist) + (org-with-silent-modifications + (add-text-properties + pos (1+ pos) (list 'org-summaries summaries-alist))))) + ;; When PROPERTY exists in current node, even if empty, + ;; but its value doesn't match the one computed, use + ;; the latter instead. + (when (and update value (not (equal value summary))) + (org-entry-put (point) property summary))) + ;; Add current to current level accumulator. + (when (or summary value-set) + (push (or summary value) (aref lvals level))) + ;; Clear accumulators for deeper levels. + (cl-loop for l from (1+ level) to lmax do (aset lvals l nil)))) + (value-set (push value (aref lvals level))) + (t nil))))))) + +;;;###autoload +(defun org-columns-compute (property) + "Summarize the values of PROPERTY hierarchically. +Also update existing values for PROPERTY according to the first +column specification." + (interactive) + (let ((main-flag t) + (upcase-prop (upcase property))) + (dolist (spec org-columns-current-fmt-compiled) + (pcase spec + (`(,(pred (equal upcase-prop)) . ,_) + (org-columns--compute-spec spec main-flag) + ;; Only the first summary can update the property value. + (when main-flag (setq main-flag nil))))))) + +(defun org-columns-compute-all () + "Compute all columns that have operators defined." + (org-with-silent-modifications + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (let ((org-columns--time (float-time (current-time))) + seen) + (dolist (spec org-columns-current-fmt-compiled) + (let ((property (car spec))) + ;; Property value is updated only the first time a given + ;; property is encountered. + (org-columns--compute-spec spec (not (member property seen))) + (push property seen))))) + +(defun org-columns--summary-sum (values printf) + "Compute the sum of VALUES. +When PRINTF is non-nil, use it to format the result." + (format (or printf "%s") (apply #'+ (mapcar #'string-to-number values)))) + +(defun org-columns--summary-currencies (values _) + "Compute the sum of VALUES, with two decimals." + (format "%.2f" (apply #'+ (mapcar #'string-to-number values)))) + +(defun org-columns--summary-checkbox (check-boxes _) + "Summarize CHECK-BOXES with a check-box." + (let ((done (cl-count "[X]" check-boxes :test #'equal)) + (all (length check-boxes))) + (cond ((= done all) "[X]") + ((> done 0) "[-]") + (t "[ ]")))) + +(defun org-columns--summary-checkbox-count (check-boxes _) + "Summarize CHECK-BOXES with a check-box cookie." + (format "[%d/%d]" + (cl-count "[X]" check-boxes :test #'equal) + (length check-boxes))) + +(defun org-columns--summary-checkbox-percent (check-boxes _) + "Summarize CHECK-BOXES with a check-box percent." + (format "[%d%%]" + (round (* 100.0 (cl-count "[X]" check-boxes :test #'equal)) + (float (length check-boxes))))) + +(defun org-columns--summary-min (values printf) + "Compute the minimum of VALUES. +When PRINTF is non-nil, use it to format the result." + (format (or printf "%s") + (apply #'min (mapcar #'string-to-number values)))) + +(defun org-columns--summary-max (values printf) + "Compute the maximum of VALUES. +When PRINTF is non-nil, use it to format the result." + (format (or printf "%s") + (apply #'max (mapcar #'string-to-number values)))) + +(defun org-columns--summary-mean (values printf) + "Compute the mean of VALUES. +When PRINTF is non-nil, use it to format the result." + (format (or printf "%s") + (/ (apply #'+ (mapcar #'string-to-number values)) + (float (length values))))) + +(defun org-columns--summary-sum-times (times _) + "Sum TIMES." + (org-columns--summary-apply-times #'+ times)) + +(defun org-columns--summary-min-time (times _) + "Compute the minimum time among TIMES." + (org-columns--summary-apply-times #'min times)) + +(defun org-columns--summary-max-time (times _) + "Compute the maximum time among TIMES." + (org-columns--summary-apply-times #'max times)) + +(defun org-columns--summary-mean-time (times _) + "Compute the mean time among TIMES." + (org-columns--summary-apply-times + (lambda (&rest values) (/ (apply #'+ values) (float (length values)))) + times)) + +(defun org-columns--summary-min-age (ages _) + "Compute the minimum time among AGES." + (format-seconds + "%dd %.2hh %mm %ss" + (apply #'min (mapcar #'org-columns--age-to-seconds ages)))) + +(defun org-columns--summary-max-age (ages _) + "Compute the maximum time among AGES." + (format-seconds + "%dd %.2hh %mm %ss" + (apply #'max (mapcar #'org-columns--age-to-seconds ages)))) + +(defun org-columns--summary-mean-age (ages _) + "Compute the minimum time among AGES." + (format-seconds + "%dd %.2hh %mm %ss" + (/ (apply #'+ (mapcar #'org-columns--age-to-seconds ages)) + (float (length ages))))) + +(defun org-columns--summary-estimate (estimates printf) + "Combine a list of estimates, using mean and variance. +The mean and variance of the result will be the sum of the means +and variances (respectively) of the individual estimates." + (let ((mean 0) + (var 0)) + (dolist (e estimates) + (pcase (mapcar #'string-to-number (split-string e "-")) + (`(,low ,high) + (let ((m (/ (+ low high) 2.0))) + (cl-incf mean m) + (cl-incf var (- (/ (+ (* low low) (* high high)) 2.0) (* m m))))) + (`(,value) (cl-incf mean value)))) + (let ((sd (sqrt var))) + (format "%s-%s" + (format (or printf "%.0f") (- mean sd)) + (format (or printf "%.0f") (+ mean sd)))))) + + + ;;; Dynamic block for Column view -(defun org-columns-capture-view (&optional maxlevel skip-empty-rows) - "Get the column view of the current buffer or subtree. -The first optional argument MAXLEVEL sets the level limit. -A second optional argument SKIP-EMPTY-ROWS tells whether to skip +(defun org-columns--capture-view (maxlevel skip-empty format local) + "Get the column view of the current buffer. + +MAXLEVEL sets the level limit. SKIP-EMPTY tells whether to skip empty rows, an empty row being one where all the column view -specifiers but ITEM are empty. This function returns a list -containing the title row and all other rows. Each row is a list -of fields." - (save-excursion - (let* ((title (mapcar #'cadr org-columns-current-fmt-compiled)) - (has-item? (member "ITEM" title)) - (n (length title)) - tbl) - (goto-char (point-min)) - (while (re-search-forward org-outline-regexp-bol nil t) - (catch 'next - (when (and (or (null maxlevel) - (>= maxlevel (org-reduced-level (org-outline-level)))) - (get-char-property (match-beginning 0) 'org-columns-key)) - (when (or (org-in-commented-heading-p t) - (member org-archive-tag (org-get-tags))) - (org-end-of-subtree t) - (throw 'next t)) - (let (row) - (dotimes (i n) - (let ((col (+ (line-beginning-position) i))) - (push (org-quote-vert - (or (get-char-property col 'org-columns-value-modified) - (get-char-property col 'org-columns-value) - "")) - row))) - (unless (and skip-empty-rows - (let ((r (delete-dups (remove "" row)))) - (or (null r) (and has-item? (= (length r) 1))))) - (push (nreverse row) tbl)))))) - (append (list title 'hline) (nreverse tbl))))) +specifiers but ITEM are empty. FORMAT is a format string for +columns, or nil. When LOCAL is non-nil, only capture headings in +current subtree. + +This function returns a list containing the title row and all +other rows. Each row is a list of fields, as strings, or +`hline'." + (org-columns (not local) format) + (goto-char org-columns-top-level-marker) + (let ((columns (length org-columns-current-fmt-compiled)) + (has-item (assoc "ITEM" org-columns-current-fmt-compiled)) + table) + (org-map-entries + (lambda () + (when (get-char-property (point) 'org-columns-key) + (let (row) + (dotimes (i columns) + (let* ((col (+ (line-beginning-position) i)) + (p (get-char-property col 'org-columns-key))) + (push (org-quote-vert + (get-char-property col + (if (string= p "ITEM") + 'org-columns-value + 'org-columns-value-modified))) + row))) + (unless (and skip-empty + (let ((r (delete-dups (remove "" row)))) + (or (null r) (and has-item (= (length r) 1))))) + (push (cons (org-reduced-level (org-current-level)) (nreverse row)) + table))))) + (and maxlevel (format "LEVEL<=%d" maxlevel)) + (and local 'tree) + 'archive 'comment) + (org-columns-quit) + ;; Add column titles and a horizontal rule in front of the table. + (cons (mapcar #'cadr org-columns-current-fmt-compiled) + (cons 'hline (nreverse table))))) + +(defun org-columns--clean-item (item) + "Remove sensitive contents from string ITEM. +This includes objects that may not be duplicated within +a document, e.g., a target, or those forbidden in tables, e.g., +an inline src-block." + (let ((data (org-element-parse-secondary-string + item (org-element-restriction 'headline)))) + (org-element-map data + '(footnote-reference inline-babel-call inline-src-block target + radio-target statistics-cookie) + #'org-element-extract-element) + (org-no-properties (org-element-interpret-data data)))) ;;;###autoload (defun org-dblock-write:columnview (params) "Write the column view table. PARAMS is a property list of parameters: -:width enforce same column widths with <N> specifiers. :id the :ID: property of the entry where the columns view should be built. When the symbol `local', call locally. When `global' call column view with the cursor at the beginning @@ -1245,139 +1383,134 @@ PARAMS is a property list of parameters: using `org-id-find'. :hlines When t, insert a hline before each item. When a number, insert a hline before each level <= that number. +:indent When non-nil, indent each ITEM field according to its level. :vlines When t, make each column a colgroup to enforce vertical lines. :maxlevel When set to a number, don't capture headlines below this level. :skip-empty-rows When t, skip rows where all specifiers other than ITEM are empty. +:width apply widths specified in columns format using <N> specifiers. :format When non-nil, specify the column view format to use." - (let ((pos (point-marker)) - (hlines (plist-get params :hlines)) - (vlines (plist-get params :vlines)) - (maxlevel (plist-get params :maxlevel)) - (content-lines (org-split-string (plist-get params :content) "\n")) - (skip-empty-rows (plist-get params :skip-empty-rows)) - (columns-fmt (plist-get params :format)) - (case-fold-search t) - tbl id idpos nfields tmp recalc line - id-as-string view-file view-pos) - (when (setq id (plist-get params :id)) - (setq id-as-string (cond ((numberp id) (number-to-string id)) - ((symbolp id) (symbol-name id)) - ((stringp id) id) - (t ""))) - (cond ((not id) nil) - ((eq id 'global) (setq view-pos (point-min))) - ((eq id 'local)) - ((string-match "^file:\\(.*\\)" id-as-string) - (setq view-file (match-string 1 id-as-string) - view-pos 1) - (unless (file-exists-p view-file) - (error "No such file: \"%s\"" id-as-string))) - ((setq idpos (org-find-entry-with-id id)) - (setq view-pos idpos)) - ((setq idpos (org-id-find id)) - (setq view-file (car idpos)) - (setq view-pos (cdr idpos))) - (t (error "Cannot find entry with :ID: %s" id)))) - (with-current-buffer (if view-file - (get-file-buffer view-file) - (current-buffer)) - (save-excursion - (save-restriction - (widen) - (goto-char (or view-pos (point))) - (org-columns columns-fmt) - (setq tbl (org-columns-capture-view maxlevel skip-empty-rows)) - (setq nfields (length (car tbl))) - (org-columns-quit)))) - (goto-char pos) - (move-marker pos nil) - (when tbl - (when (plist-get params :hlines) - (setq tmp nil) - (while tbl - (if (eq (car tbl) 'hline) - (push (pop tbl) tmp) - (if (string-match "\\` *\\(\\*+\\)" (caar tbl)) - (if (and (not (eq (car tmp) 'hline)) - (or (eq hlines t) - (and (numberp hlines) - (<= (- (match-end 1) (match-beginning 1)) - hlines)))) - (push 'hline tmp))) - (push (pop tbl) tmp))) - (setq tbl (nreverse tmp))) - (when vlines - (setq tbl (mapcar (lambda (x) - (if (eq 'hline x) x (cons "" x))) - tbl)) - (setq tbl (append tbl (list (cons "/" (make-list nfields "<>")))))) - (when content-lines - (while (string-match "^#" (car content-lines)) - (insert (pop content-lines) "\n"))) - (setq pos (point)) - (insert (org-listtable-to-string tbl)) + (let ((table + (let ((id (plist-get params :id)) + view-file view-pos) + (pcase id + (`global nil) + ((or `local `nil) (setq view-pos (point))) + ((and (let id-string (format "%s" id)) + (guard (string-match "^file:\\(.*\\)" id-string))) + (setq view-file (match-string-no-properties 1 id-string)) + (unless (file-exists-p view-file) + (user-error "No such file: %S" id-string))) + ((and (let idpos (org-find-entry-with-id id)) (guard idpos)) + (setq view-pos idpos)) + ((let `(,filename . ,position) (org-id-find id)) + (setq view-file filename) + (setq view-pos position)) + (_ (user-error "Cannot find entry with :ID: %s" id))) + (with-current-buffer (if view-file (get-file-buffer view-file) + (current-buffer)) + (org-with-wide-buffer + (when view-pos (goto-char view-pos)) + (org-columns--capture-view (plist-get params :maxlevel) + (plist-get params :skip-empty-rows) + (plist-get params :format) + view-pos)))))) + (when table + ;; Prune level information from the table. Also normalize + ;; headings: remove stars, add indentation entities, if + ;; required, and possibly precede some of them with a horizontal + ;; rule. + (let ((item-index + (let ((p (assoc "ITEM" org-columns-current-fmt-compiled))) + (and p (cl-position p + org-columns-current-fmt-compiled + :test #'equal)))) + (hlines (plist-get params :hlines)) + (indent (plist-get params :indent)) + new-table) + ;; Copy header and first rule. + (push (pop table) new-table) + (push (pop table) new-table) + (dolist (row table (setq table (nreverse new-table))) + (let ((level (car row))) + (when (and (not (eq (car new-table) 'hline)) + (or (eq hlines t) + (and (numberp hlines) (<= level hlines)))) + (push 'hline new-table)) + (when item-index + (let ((item (org-columns--clean-item (nth item-index (cdr row))))) + (setf (nth item-index (cdr row)) + (if (and indent (> level 1)) + (concat "\\_" (make-string (* 2 (1- level)) ?\s) item) + item)))) + (push (cdr row) new-table)))) (when (plist-get params :width) - (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x))) - org-columns-current-widths "|"))) - (while (setq line (pop content-lines)) - (when (string-match "^#" line) - (insert "\n" line) - (when (string-match "^[ \t]*#\\+tblfm" line) - (setq recalc t)))) - (if recalc - (progn (goto-char pos) (org-table-recalculate 'all)) - (goto-char pos) + (setq table + (append table + (list + (mapcar (lambda (spec) + (let ((w (nth 2 spec))) + (if w (format "<%d>" (max 3 w)) ""))) + org-columns-current-fmt-compiled))))) + (when (plist-get params :vlines) + (setq table + (let ((size (length org-columns-current-fmt-compiled))) + (append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x))) + table) + (list (cons "/" (make-list size "<>"))))))) + (let ((content-lines (org-split-string (plist-get params :content) "\n")) + recalc) + ;; Insert affiliated keywords before the table. + (when content-lines + (while (string-match-p "\\`[ \t]*#\\+" (car content-lines)) + (insert (pop content-lines) "\n"))) + (save-excursion + ;; Insert table at point. + (insert + (mapconcat (lambda (row) + (if (eq row 'hline) "|-|" + (format "|%s|" (mapconcat #'identity row "|")))) + table + "\n")) + ;; Insert TBLFM lines following table. + (let ((case-fold-search t)) + (dolist (line content-lines) + (when (string-match-p "\\`[ \t]*#\\+TBLFM:" line) + (insert "\n" line) + (unless recalc (setq recalc t)))))) + (when recalc (org-table-recalculate 'all t)) (org-table-align))))) -(defun org-listtable-to-string (tbl) - "Convert a listtable TBL to a string that contains the Org-mode table. -The table still need to be aligned. The resulting string has no leading -and tailing newline characters." - (mapconcat - (lambda (x) - (cond - ((listp x) - (concat "|" (mapconcat 'identity x "|") "|")) - ((eq x 'hline) "|-|") - (t (error "Garbage in listtable: %s" x)))) - tbl "\n")) - ;;;###autoload -(defun org-insert-columns-dblock () +(defun org-columns-insert-dblock () "Create a dynamic block capturing a column view table." (interactive) - (let ((defaults '(:name "columnview" :hlines 1)) - (id (org-icompleting-read + (let ((id (completing-read "Capture columns (local, global, entry with :ID: property) [local]: " (append '(("global") ("local")) - (mapcar 'list (org-property-values "ID")))))) - (if (equal id "") (setq id 'local)) - (if (equal id "global") (setq id 'global)) - (setq defaults (append defaults (list :id id))) - (org-create-dblock defaults) - (org-update-dblock))) - -;;; Column view in the agenda + (mapcar #'list (org-property-values "ID")))))) + (org-create-dblock + (list :name "columnview" + :hlines 1 + :id (cond ((string= id "global") 'global) + ((member id '("" "local")) 'local) + (id))))) + (org-update-dblock)) -(defvar org-agenda-view-columns-initially nil - "When set, switch to columns view immediately after creating the agenda.") -(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 + +;;; Column view in the agenda ;;;###autoload (defun org-agenda-columns () "Turn on or update column view in the agenda." (interactive) - (org-verify-version 'columns) (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) - (let ((org-columns-time (time-to-number-of-days (current-time))) + (let ((org-columns--time (float-time (current-time))) (fmt (cond - ((org-bound-and-true-p org-agenda-overriding-columns-format)) + ((bound-and-true-p org-agenda-overriding-columns-format)) ((let ((m (org-get-at-bol 'org-hd-marker))) (and m (or (org-entry-get m "COLUMNS" t) @@ -1392,7 +1525,7 @@ and tailing newline characters." (with-current-buffer (marker-buffer m) org-columns-default-format)))))) (t org-columns-default-format)))) - (org-set-local 'org-columns-current-fmt fmt) + (setq-local org-columns-current-fmt fmt) (org-columns-compile-format fmt) (when org-agenda-columns-compute-summary-properties (org-agenda-colview-compute org-columns-current-fmt-compiled)) @@ -1400,204 +1533,111 @@ 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 - (if (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) - 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 - (org-set-local 'org-columns-current-maxwidths - (org-columns-get-autowidth-alist fmt cache)) - (org-columns-display-here-title) - (when (org-set-local 'org-columns-flyspell-was-active - (org-bound-and-true-p flyspell-mode)) + (org-columns--set-widths cache) + (org-columns--display-here-title) + (when (setq-local org-columns-flyspell-was-active + (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 title) - (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) - title (nth 1 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) - (org-set-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 property '("CLOCKSUM" "CLOCKSUM_T")) + (list property title width ":" nil) + spec)))) + org-columns-current-fmt-compiled)) + entries) + ;; Ensure there's at least one summation column. + (when (cl-some (lambda (spec) (nth 3 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 + (`("ITEM" . ,_) + ;; Replace ITEM with current date. Preserve + ;; properties for fontification. + (let ((date (buffer-substring + (line-beginning-position) + (line-end-position)))) + (list spec date date))) + (`(,_ ,_ ,_ nil ,_) (list spec "" "")) + (`(,_ ,_ ,_ ,operator ,printf) + (let* ((summarize (org-columns--summarize operator)) + (values + ;; Use real values for summary, not those + ;; prepared for display. + (delq nil + (mapcar + (lambda (e) + (org-string-nw-p (nth 1 (assoc spec e)))) + entries))) + (final (if values (funcall summarize values printf) + ""))) + (unless (equal final "") + (put-text-property 0 (length final) 'face 'bold final)) + (list spec final final))))) + 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." (let ((files org-agenda-contributing-files) (org-columns-begin-marker (make-marker)) - (org-columns-top-level-marker (make-marker)) - f fm a b) - (while (setq f (pop files)) - (setq b (find-buffer-visiting f)) - (with-current-buffer (or (buffer-base-buffer b) b) - (save-excursion - (save-restriction - (widen) - (org-with-silent-modifications - (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (goto-char (point-min)) - (org-columns-get-format-and-top-level) - (while (setq fm (pop fmt)) - (cond ((equal (car fm) "CLOCKSUM") - (org-clock-sum)) - ((equal (car fm) "CLOCKSUM_T") - (org-clock-sum-today)) - ((and (nth 4 fm) - (setq a (assoc-string (car fm) - org-columns-current-fmt-compiled - t)) - (equal (nth 4 a) (nth 4 fm))) - (org-columns-compute (car fm))))))))))) - -(defun org-format-time-period (interval) - "Convert time in fractional days to days/hours/minutes/seconds." - (if (numberp interval) - (let* ((days (floor interval)) - (frac-hours (* 24 (- interval days))) - (hours (floor frac-hours)) - (minutes (floor (* 60 (- frac-hours hours)))) - (seconds (floor (* 60 (- (* 60 (- frac-hours hours)) minutes))))) - (format "%dd %02dh %02dm %02ds" days hours minutes seconds)) - "")) - -(defun org-estimate-mean-and-var (v) - "Return the mean and variance of an estimate." - (let* ((v (cond ((consp v) v) - ((numberp v) (list v v)) - (t (error "Invalid estimate type")))) - (low (float (car v))) - (high (float (cadr v))) - (mean (/ (+ low high) 2.0)) - (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0))) - (list mean var))) - -(defun org-estimate-combine (&rest el) - "Combine a list of estimates, using mean and variance. -The mean and variance of the result will be the sum of the means -and variances (respectively) of the individual estimates." - (let ((mean 0) - (var 0)) - (mapc (lambda (e) - (let ((stats (org-estimate-mean-and-var e))) - (setq mean (+ mean (car stats))) - (setq var (+ var (cadr stats))))) - el) - (let ((stdev (sqrt var))) - (list (- mean stdev) (+ mean stdev))))) - -(defun org-estimate-print (e &optional fmt) - "Prepare a string representation of an estimate. -This formats these numbers as two numbers with a \"-\" between them." - (let ((fmt (or fmt "%.0f")) - (e (cond ((consp e) e) - ((numberp e) (list e e)) - (t (error "Invalid estimate type"))))) - (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-")))) - -(defun org-string-to-estimate (s) - "Convert a string to an estimate. -The string should be two numbers joined with a \"-\"." - (if (string-match "\\(.*\\)-\\(.*\\)" s) - (list (string-to-number (match-string 1 s)) - (string-to-number(match-string 2 s))) - (list (string-to-number s) (string-to-number s)))) + (org-columns-top-level-marker (make-marker))) + (dolist (f files) + (let ((b (find-buffer-visiting f))) + (with-current-buffer (or (buffer-base-buffer b) b) + (org-with-wide-buffer + (org-with-silent-modifications + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (goto-char (point-min)) + (org-columns-get-format-and-top-level) + (dolist (spec fmt) + (let ((prop (car spec))) + (cond + ((equal prop "CLOCKSUM") (org-clock-sum)) + ((equal prop "CLOCKSUM_T") (org-clock-sum-today)) + ((and (nth 3 spec) + (let ((a (assoc prop org-columns-current-fmt-compiled))) + (equal (nth 3 a) (nth 3 spec)))) + (org-columns-compute prop))))))))))) + (provide 'org-colview) |