diff options
Diffstat (limited to 'lisp/org/org-colview.el')
| -rw-r--r-- | lisp/org/org-colview.el | 325 |
1 files changed, 198 insertions, 127 deletions
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 51a8eff33d7..caef4251443 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -41,6 +41,9 @@ (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)) +(declare-function org-dynamic-block-define "org" (type func)) +(declare-function org-link-display-format "ol" (s)) +(declare-function org-link-open-from-string "ol" (s &optional arg)) (defvar org-agenda-columns-add-appointments-to-effort-sum) (defvar org-agenda-columns-compute-summary-properties) @@ -67,7 +70,8 @@ or nil if the normal value should be used." (defcustom org-columns-summary-types nil "Alist between operators and summarize functions. -Each association follows the pattern (LABEL . SUMMARIZE) where +Each association follows the pattern (LABEL . SUMMARIZE), +or (LABEL SUMMARIZE COLLECT) where LABEL is a string used in #+COLUMNS definition describing the summary type. It can contain any character but \"}\". It is @@ -78,6 +82,13 @@ Each association follows the pattern (LABEL . SUMMARIZE) where The second one is a format string or nil. It has to return a string summarizing the list of values. + COLLECT is a function called with one argument, a property + name. It is called in the context of a headline and must + return the collected property, or the empty string. You can + use this to only collect a property if a related conditional + properties is set, e.g., to return VACATION_DAYS only if + CONFIRMED is true. + Note that the return value can become one value for an higher order summary, so the function is expected to handle its own output. @@ -88,7 +99,11 @@ in `org-columns-summary-types-default', which see." :version "26.1" :package-version '(Org . "9.0") :type '(alist :key-type (string :tag " Label") - :value-type (function :tag "Summarize"))) + :value-type + (choice (function :tag "Summarize") + (list :tag "Collect and summarize" + (function :tag "Summarize") + (function :tag "Collect"))))) @@ -221,21 +236,27 @@ See `org-columns-summary-types' for details.") "--" ["Quit" org-columns-quit t])) -(defun org-columns--displayed-value (spec value) +(defun org-columns--displayed-value (spec value &optional no-star) "Return displayed value for specification SPEC in current entry. + SPEC is a column format specification as stored in `org-columns-current-fmt-compiled'. VALUE is the real value to -display, as a string." +display, as a string. + +When NO-STAR is non-nil, do not add asterisks before displayed +value for ITEM property." (or (and (functionp org-columns-modify-value-for-display-function) (funcall org-columns-modify-value-for-display-function (nth 1 spec) ;column name value)) (pcase spec (`("ITEM" . ,_) - (concat (make-string (1- (org-current-level)) - (if org-hide-leading-stars ?\s ?*)) - "* " - (org-columns-compact-links value))) + (let ((stars + (and (not no-star) + (concat (make-string (1- (org-current-level)) + (if org-hide-leading-stars ?\s ?*)) + "* ")))) + (concat stars (org-link-display-format value)))) (`(,_ ,_ ,_ ,_ nil) value) ;; If PRINTF is set, assume we are displaying a number and ;; obey to the format string. @@ -268,7 +289,11 @@ possible to override it with optional argument COMPILED-FMT." (get-text-property (point) 'duration)) 'face 'org-warning)) ""))) - (list spec v (org-columns--displayed-value spec v)))))) + ;; A non-nil COMPILED-FMT means we're calling from Org + ;; Agenda mode, where we do not want leading stars for + ;; ITEM. Hence the optional argument for + ;; `org-columns--displayed-value'. + (list spec v (org-columns--displayed-value spec v compiled-fmt)))))) (or compiled-fmt org-columns-current-fmt-compiled)))) (defun org-columns--set-widths (cache) @@ -301,13 +326,29 @@ integers greater than 0." (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))))) + (pcase (or (assoc operator org-columns-summary-types) + (assoc operator org-columns-summary-types-default)) + (`nil (error "Unknown %S operator" operator)) + (`(,_ . ,(and (pred functionp) summarize)) summarize) + (`(,_ ,summarize ,_) summarize) + (_ (error "Invalid definition for operator %S" operator)))) + +(defun org-columns--collect (operator) + "Return collect function associated to string OPERATOR. +Return nil if no collect function is associated to OPERATOR." + (pcase (or (assoc operator org-columns-summary-types) + (assoc operator org-columns-summary-types-default)) + (`nil (error "Unknown %S operator" operator)) + (`(,_ . ,(pred functionp)) nil) ;default value + (`(,_ ,_ ,collect) collect) + (_ (error "Invalid definition for operator %S" operator)))) (defun org-columns--overlay-text (value fmt width property original) - "Return text." + "Return decorated VALUE string for columns overlay display. +FMT is a format string. WIDTH is the width of the column, as an +integer. PROPERTY is the property being displayed, as a string. +ORIGINAL is the real string, i.e., before it is modified by +`org-columns--displayed-value'." (format fmt (let ((v (org-columns-add-ellipses value width))) (pcase property @@ -387,14 +428,14 @@ DATELINE is non-nil when the face used should be (line-beginning-position 2)))) (overlay-put ov 'keymap org-columns-map) (push ov org-columns-overlays)) - (org-with-silent-modifications - (let ((inhibit-read-only t)) - (put-text-property - (line-end-position 0) - (line-beginning-position 2) - 'read-only - (substitute-command-keys - "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ + (with-silent-modifications + (let ((inhibit-read-only t)) + (put-text-property + (line-end-position 0) + (line-beginning-position 2) + 'read-only + (substitute-command-keys + "Type \\<org-columns-map>`\\[org-columns-edit-value]' \ to edit property"))))))) (defun org-columns-add-ellipses (string width) @@ -424,6 +465,7 @@ for the duration of the command.") "Overlay the newline before the current line with the table title." (interactive) (let ((title "") + (linum-offset (org-line-number-display-width 'columns)) (i 0)) (dolist (column org-columns-current-fmt-compiled) (pcase column @@ -435,7 +477,7 @@ for the duration of the command.") (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 " " nil 'display `(space :align-to ,linum-offset)) (org-add-props (substring title 0 -1) nil 'face 'org-column-title))) (setq org-columns-previous-hscroll -1) (add-hook 'post-command-hook 'org-columns-hscroll-title nil 'local))) @@ -443,13 +485,15 @@ for the duration of the command.") (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)) - (setq header-line-format - (concat (substring org-columns-full-header-line-format 0 1) - (substring org-columns-full-header-line-format - (1+ (window-hscroll)))) - org-columns-previous-hscroll (window-hscroll)) - (force-mode-line-update))) + (let ((hscroll (window-hscroll))) + (when (/= org-columns-previous-hscroll hscroll) + (setq header-line-format + (concat (substring org-columns-full-header-line-format 0 1) + (substring org-columns-full-header-line-format + (min (length org-columns-full-header-line-format) + (1+ hscroll)))) + org-columns-previous-hscroll hscroll) + (force-mode-line-update)))) (defvar org-colview-initial-truncate-line-value nil "Remember the value of `truncate-lines' across colview.") @@ -466,24 +510,16 @@ for the duration of the command.") (set-marker org-columns-begin-marker nil) (when (markerp org-columns-top-level-marker) (set-marker org-columns-top-level-marker nil)) - (org-with-silent-modifications - (mapc #'delete-overlay org-columns-overlays) - (setq org-columns-overlays nil) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) + (with-silent-modifications + (mapc #'delete-overlay org-columns-overlays) + (setq org-columns-overlays nil) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) (when org-columns-flyspell-was-active (flyspell-mode 1)) (when (local-variable-p 'org-colview-initial-truncate-line-value) (setq truncate-lines org-colview-initial-truncate-line-value)))) -(defun org-columns-compact-links (s) - "Replace [[link][desc]] with [desc] or [link]." - (while (string-match org-bracket-link-regexp s) - (setq s (replace-match - (concat "[" (match-string (if (match-end 3) 3 1) s) "]") - t t s))) - s) - (defun org-columns-show-value () "Show the full value of the property." (interactive) @@ -495,10 +531,10 @@ for the duration of the command.") (defun org-columns-quit () "Remove the column overlays and in this way exit column editing." (interactive) - (org-with-silent-modifications - (org-columns-remove-overlays) - (let ((inhibit-read-only t)) - (remove-text-properties (point-min) (point-max) '(read-only t)))) + (with-silent-modifications + (org-columns-remove-overlays) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) (if (not (eq major-mode 'org-agenda-mode)) (setq org-columns-current-fmt nil) (setq org-agenda-columns-active nil) @@ -526,9 +562,17 @@ for the duration of the command.") (org-columns-next-allowed-value) (org-columns-edit-value "TAGS"))) -(defvar org-agenda-overriding-columns-format nil +(defvar org-overriding-columns-format nil + "When set, overrides any other format definition for the agenda. +Don't set this, this is meant for dynamic scoping. Set +`org-columns-default-format' and `org-columns-default-format-for-agenda' +instead. You should use this variable only in the local settings +section for a custom agenda view.") + +(defvar-local org-local-columns-format nil "When set, overrides any other format definition for the agenda. -Don't set this, this is meant for dynamic scoping.") +This can be set as a buffer local value to avoid interfering with +dynamic scoping for `org-overriding-columns-format'.") (defun org-columns-edit-value (&optional key) "Edit the value of the property at point in column view. @@ -544,7 +588,7 @@ Where possible, use the standard interface for changing this line." (action (pcase key ("CLOCKSUM" - (error "This special column cannot be edited")) + (user-error "This special column cannot be edited")) ("ITEM" (lambda () (org-with-point-at pom (org-edit-headline)))) ("TODO" @@ -561,7 +605,7 @@ Where possible, use the standard interface for changing this line." (if (eq org-fast-tag-selection-single-key 'expert) t org-fast-tag-selection-single-key))) - (call-interactively #'org-set-tags))))) + (call-interactively #'org-set-tags-command))))) ("DEADLINE" (lambda () (org-with-point-at pom (call-interactively #'org-deadline)))) @@ -589,7 +633,7 @@ Where possible, use the standard interface for changing this line." (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) + (let* ((org-overriding-columns-format org-columns-current-fmt) (buffer (marker-buffer pom)) (org-agenda-contributing-files (list (with-current-buffer buffer @@ -597,8 +641,8 @@ Where possible, use the standard interface for changing this line." (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))) + (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 @@ -683,7 +727,7 @@ an integer, select that value." (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) + (let* ((org-overriding-columns-format org-columns-current-fmt) (buffer (marker-buffer pom)) (org-agenda-contributing-files (list (with-current-buffer buffer @@ -719,13 +763,13 @@ around it." (setq time-after (copy-sequence time)) (setf (nth 3 time-before) (1- (nth 3 time))) (setf (nth 3 time-after) (1+ (nth 3 time))) - (mapcar (lambda (x) (format-time-string fmt (encode-time x))) + (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) (list time-before time time-after))))) (defun org-columns-open-link (&optional arg) (interactive "P") (let ((value (get-char-property (point) 'org-columns-value))) - (org-open-link-from-string value arg))) + (org-link-open-from-string value arg))) ;;;###autoload (defun org-columns-get-format-and-top-level () @@ -783,17 +827,17 @@ view for the whole buffer unconditionally. When COLUMNS-FMT-STRING is non-nil, use it as the column format." (interactive "P") (org-columns-remove-overlays) - (when global (goto-char (point-min))) - (if (markerp org-columns-begin-marker) - (move-marker org-columns-begin-marker (point)) - (setq org-columns-begin-marker (point-marker))) - (org-columns-goto-top-level) - ;; Initialize `org-columns-current-fmt' and - ;; `org-columns-current-fmt-compiled'. - (let ((org-columns--time (float-time))) - (org-columns-get-format columns-fmt-string) - (unless org-columns-inhibit-recalculation (org-columns-compute-all)) - (save-excursion + (save-excursion + (when global (goto-char (point-min))) + (if (markerp org-columns-begin-marker) + (move-marker org-columns-begin-marker (point)) + (setq org-columns-begin-marker (point-marker))) + (org-columns-goto-top-level) + ;; Initialize `org-columns-current-fmt' and + ;; `org-columns-current-fmt-compiled'. + (let ((org-columns--time (float-time))) + (org-columns-get-format columns-fmt-string) + (unless org-columns-inhibit-recalculation (org-columns-compute-all)) (save-restriction (when (and (not global) (org-at-heading-p)) (narrow-to-region (point) (org-end-of-subtree t t))) @@ -1011,8 +1055,8 @@ the current buffer." (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." + +COMPILED is an alist, as returned by `org-columns-compile-format'." (mapconcat (lambda (spec) (pcase spec @@ -1085,16 +1129,7 @@ as a canonical duration, i.e., using units defined in "Apply FUN to time values TIMES. Return the result as a duration." (org-duration-from-minutes - (apply fun - (mapcar (lambda (time) - ;; Unlike to `org-duration-to-minutes' standard - ;; behavior, we want to consider plain numbers as - ;; hours. As a consequence, we treat them - ;; differently. - (if (string-match-p "\\`[0-9]+\\(?:\\.[0-9]*\\)?\\'" time) - (* 60 (string-to-number time)) - (org-duration-to-minutes time))) - times)) + (apply fun (mapcar #'org-duration-to-minutes times)) (org-duration-h:mm-only-p times))) (defun org-columns--compute-spec (spec &optional update) @@ -1111,7 +1146,9 @@ properties drawers." (last-level lmax) (property (car spec)) (printf (nth 4 spec)) - (summarize (org-columns--summarize (nth 3 spec)))) + (operator (nth 3 spec)) + (collect (and operator (org-columns--collect operator))) + (summarize (and operator (org-columns--summarize operator)))) (org-with-wide-buffer ;; Find the region to compute. (goto-char org-columns-top-level-marker) @@ -1123,7 +1160,8 @@ properties drawers." (setq last-level level)) (setq level (org-reduced-level (org-outline-level))) (let* ((pos (match-beginning 0)) - (value (org-entry-get nil property)) + (value (if collect (funcall collect property) + (org-entry-get (point) property))) (value-set (org-string-nw-p value))) (cond ((< level last-level) @@ -1142,9 +1180,9 @@ properties drawers." (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))))) + (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. @@ -1180,9 +1218,9 @@ column specification." (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))) + (with-silent-modifications + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (let ((org-columns--time (float-time)) seen) (dolist (spec org-columns-current-fmt-compiled) (let ((property (car spec))) @@ -1212,7 +1250,7 @@ When PRINTF is non-nil, use it to format the result." "Summarize CHECK-BOXES with a check-box cookie." (format "[%d/%d]" (cl-count-if (lambda (b) (or (equal b "[X]") - (string-match-p "\\[\\([1-9]\\)/\\1\\]" b))) + (string-match-p "\\[\\([1-9]\\)/\\1\\]" b))) check-boxes) (length check-boxes))) @@ -1261,17 +1299,17 @@ When PRINTF is non-nil, use it to format the result." times)) (defun org-columns--summary-min-age (ages _) - "Compute the minimum time among AGES." + "Compute the minimum age among AGES." (org-columns--format-age (apply #'min (mapcar #'org-columns--age-to-minutes ages)))) (defun org-columns--summary-max-age (ages _) - "Compute the maximum time among AGES." + "Compute the maximum age among AGES." (org-columns--format-age (apply #'max (mapcar #'org-columns--age-to-minutes ages)))) (defun org-columns--summary-mean-age (ages _) - "Compute the minimum time among AGES." + "Compute the mean age among AGES." (org-columns--format-age (/ (apply #'+ (mapcar #'org-columns--age-to-minutes ages)) (float (length ages))))) @@ -1298,14 +1336,15 @@ and variances (respectively) of the individual estimates." ;;; Dynamic block for Column view -(defun org-columns--capture-view (maxlevel skip-empty format local) +(defun org-columns--capture-view (maxlevel match skip-empty exclude-tags 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. FORMAT is a format string for -columns, or nil. When LOCAL is non-nil, only capture headings in -current subtree. +specifiers but ITEM are empty. EXCLUDE-TAGS is a list of tags +that will be excluded from the resulting view. 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 @@ -1328,12 +1367,17 @@ other rows. Each row is a list of fields, as strings, or '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))))) + (unless (or + (and skip-empty + (let ((r (delete-dups (remove "" row)))) + (or (null r) (and has-item (= (length r) 1))))) + (and exclude-tags + (cl-some (lambda (tag) (member tag exclude-tags)) + (org-get-tags)))) (push (cons (org-reduced-level (org-current-level)) (nreverse row)) table))))) - (and maxlevel (format "LEVEL<=%d" maxlevel)) + (or (and maxlevel (format "LEVEL<=%d" maxlevel)) + (and match match)) (and local 'tree) 'archive 'comment) (org-columns-quit) @@ -1357,24 +1401,54 @@ an inline src-block." ;;;###autoload (defun org-dblock-write:columnview (params) "Write the column view table. + PARAMS is a property list of parameters: -: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 - of the buffer (usually this means that the whole buffer switches - to column view). When \"file:path/to/file.org\", invoke column - view at the start of that file. Otherwise, the ID is located - 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." +`:id' (mandatory) + + 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 of the + buffer (usually this means that the whole buffer switches to + column view). When \"file:path/to/file.org\", invoke column + view at the start of that file. Otherwise, the ID is located + using `org-id-find'. + +`:exclude-tags' + + List of tags to exclude from column view table. + +`:format' + + When non-nil, specify the column view format to use. + +`:hlines' + + When non-nil, insert a hline before each item. When + a number, insert a hline before each level inferior or equal + to that number. + +`:indent' + + When non-nil, indent each ITEM field according to its level. + +`:match' + + When set to a string, use this as a tags/property match filter. + +`:maxlevel' + + When set to a number, don't capture headlines below this level. + +`:skip-empty-rows' + + When non-nil, skip rows where all specifiers other than ITEM + are empty. + +`:vlines' + + When non-nil, make each column a column group to enforce + vertical lines." (let ((table (let ((id (plist-get params :id)) view-file view-pos) @@ -1397,7 +1471,9 @@ PARAMS is a property list of parameters: (org-with-wide-buffer (when view-pos (goto-char view-pos)) (org-columns--capture-view (plist-get params :maxlevel) + (plist-get params :match) (plist-get params :skip-empty-rows) + (plist-get params :exclude-tags) (plist-get params :format) view-pos)))))) (when table @@ -1429,14 +1505,6 @@ PARAMS is a property list of parameters: (concat "\\_" (make-string (* 2 (1- level)) ?\s) item) item)))) (push (cdr row) new-table)))) - (when (plist-get params :width) - (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))) @@ -1482,6 +1550,7 @@ PARAMS is a property list of parameters: (id))))) (org-update-dblock)) +(org-dynamic-block-define "columnview" #'org-columns-insert-dblock) ;;; Column view in the agenda @@ -1497,7 +1566,9 @@ PARAMS is a property list of parameters: (let* ((org-columns--time (float-time)) (fmt (cond - ((bound-and-true-p org-agenda-overriding-columns-format)) + ((bound-and-true-p org-overriding-columns-format)) + ((bound-and-true-p org-local-columns-format)) + ((bound-and-true-p org-columns-default-format-for-agenda)) ((let ((m (org-get-at-bol 'org-hd-marker))) (and m (or (org-entry-get m "COLUMNS" t) @@ -1616,8 +1687,8 @@ This will add overlays to the date lines, to show the summary for each day." (let ((b (find-buffer-visiting file))) (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))) + (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) |