diff options
Diffstat (limited to 'lisp/org/org-colview.el')
| -rw-r--r-- | lisp/org/org-colview.el | 159 |
1 files changed, 94 insertions, 65 deletions
diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 5cec355d738..e17210b7ff5 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -33,9 +33,10 @@ (declare-function org-agenda-redo "org-agenda" ()) (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'.")) + (error "Do not load this file into XEmacs, use `org-colview-xemacs.el'")) ;;; Column View @@ -149,6 +150,7 @@ This is the compiled version of the format.") "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)) + (remove-text-properties 0 (length string) '(face nil) string) (org-overlay-display ov string face) (push ov org-columns-overlays) ov)) @@ -186,17 +188,15 @@ This is the compiled version of the format.") (cons "ITEM" ;; When in a buffer, get the whole line, ;; we'll clean it later… - (if (eq major-mode 'org-mode) + (if (derived-mode-p 'org-mode) (save-match-data - (org-no-properties - (org-remove-tabs - (buffer-substring-no-properties - (point-at-bol) (point-at-eol))))) + (org-remove-tabs + (buffer-substring-no-properties + (point-at-bol) (point-at-eol)))) ;; In agenda, just get the `txt' property - (org-no-properties - (or (org-get-at-bol 'txt) - (buffer-substring - (point) (progn (end-of-line) (point))))))) + (or (org-get-at-bol 'txt) + (buffer-substring-no-properties + (point) (progn (end-of-line) (point)))))) (assoc property props)) width (or (cdr (assoc property org-columns-current-maxwidths)) (nth 2 column) @@ -240,20 +240,20 @@ This is the compiled version of the format.") (save-excursion (goto-char beg) (org-unmodified (insert " ")))))) ;; FIXME: add props and remove later? - ;; Make the rest of the line disappear. - (org-unmodified - (setq ov (org-columns-new-overlay beg (point-at-eol))) - (overlay-put ov 'invisible t) - (overlay-put ov 'keymap org-columns-map) - (overlay-put ov 'intangible t) - (overlay-put ov 'line-prefix "") - (overlay-put ov 'wrap-prefix "") - (push ov org-columns-overlays) - (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) - (overlay-put ov 'keymap org-columns-map) - (push ov org-columns-overlays) - (let ((inhibit-read-only t)) - (put-text-property (max (point-min) (1- (point-at-bol))) + ;; Make the rest of the line disappear. + (org-unmodified + (setq ov (org-columns-new-overlay beg (point-at-eol))) + (overlay-put ov 'invisible t) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'intangible t) + (overlay-put ov 'line-prefix "") + (overlay-put ov 'wrap-prefix "") + (push ov org-columns-overlays) + (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) + (overlay-put ov 'keymap org-columns-map) + (push ov org-columns-overlays) + (let ((inhibit-read-only t)) + (put-text-property (max (point-min) (1- (point-at-bol))) (min (point-max) (1+ (point-at-eol))) 'read-only "Type `e' to edit property"))))) @@ -304,7 +304,7 @@ for the duration of the command.") (org-set-local 'org-columns-current-widths (nreverse widths)) (setq org-columns-full-header-line-format title) (setq org-columns-previous-hscroll -1) -; (org-columns-hscoll-title) + ; (org-columns-hscoll-title) (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local))) (defun org-columns-hscoll-title () @@ -442,8 +442,8 @@ Where possible, use the standard interface for changing this line." (org-edit-headline)))) ((equal key "TODO") (setq eval '(org-with-point-at - pom - (call-interactively 'org-todo)))) + pom + (call-interactively 'org-todo)))) ((equal key "PRIORITY") (setq eval '(org-with-point-at pom (call-interactively 'org-priority)))) @@ -499,7 +499,7 @@ Where possible, use the standard interface for changing this line." (org-columns-eval eval)) (org-columns-display-here))) (org-move-to-column col) - (if (and (eq major-mode 'org-mode) + (if (and (derived-mode-p 'org-mode) (nth 3 (assoc key org-columns-current-fmt-compiled))) (org-columns-update key))))))) @@ -665,27 +665,38 @@ around it." (org-open-link-from-string value arg))) (defun org-columns-get-format-and-top-level () - (let (fmt) + (let ((fmt (org-columns-get-format))) + (org-columns-goto-top-level) + fmt)) + +(defun org-columns-get-format (&optional fmt-string) + (interactive) + (let (fmt-as-property fmt) (when (condition-case nil (org-back-to-heading) (error nil)) - (setq fmt (org-entry-get nil "COLUMNS" t))) - (setq fmt (or fmt org-columns-default-format)) + (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) - (if (marker-position org-entry-property-inherited-from) - (move-marker org-columns-top-level-marker - org-entry-property-inherited-from) - (move-marker org-columns-top-level-marker (point))) fmt)) -(defun org-columns () - "Turn on column view on an org-mode file." +(defun org-columns-goto-top-level () + (when (condition-case nil (org-back-to-heading) (error nil)) + (org-entry-get nil "COLUMNS" t)) + (if (marker-position org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker (point)))) + +(defun org-columns (&optional columns-fmt-string) + "Turn on column view on an org-mode file. +When COLUMNS-FMT-STRING is non-nil, use it as the column format." (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))) beg end fmt cache maxwidths) - (setq fmt (org-columns-get-format-and-top-level)) + (org-columns-goto-top-level) + (setq fmt (org-columns-get-format columns-fmt-string)) (save-excursion (goto-char org-columns-top-level-marker) (setq beg (point)) @@ -700,6 +711,11 @@ around it." (save-restriction (narrow-to-region beg end) (org-clock-sum)))) + (when (assoc "CLOCKSUM_T" org-columns-current-fmt-compiled) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (org-clock-sum-today)))) (while (re-search-forward org-outline-regexp-bol end t) (if (and org-columns-skip-archived-trees (looking-at (concat ".*:" org-archive-tag ":"))) @@ -1014,7 +1030,7 @@ Don't set this, this is meant for dynamic scoping.") (if (marker-position org-columns-begin-marker) (goto-char org-columns-begin-marker)) (org-columns-remove-overlays) - (if (eq major-mode 'org-mode) + (if (derived-mode-p 'org-mode) (call-interactively 'org-columns) (org-agenda-redo) (call-interactively 'org-agenda-columns))) @@ -1083,6 +1099,14 @@ Don't set this, this is meant for dynamic scoping.") (while l (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) sum)) + ((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)) ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) (if (equal s "[X]") 1. 0.000001)) ((memq fmt '(estimate)) (org-string-to-estimate s)) @@ -1215,13 +1239,16 @@ PARAMS is a property list of parameters: :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." + When t, skip rows where all specifiers other than ITEM are empty. +:format When non-nil, specify the column view format to use." (let ((pos (move-marker (make-marker) (point))) (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)) @@ -1250,7 +1277,7 @@ PARAMS is a property list of parameters: (save-restriction (widen) (goto-char (or view-pos (point))) - (org-columns) + (org-columns columns-fmt) (setq tbl (org-columns-capture-view maxlevel skip-empty-rows)) (setq nfields (length (car tbl))) (org-columns-quit)))) @@ -1287,7 +1314,7 @@ PARAMS is a property list of parameters: (while (setq line (pop content-lines)) (when (string-match "^#" line) (insert "\n" line) - (when (string-match "^[ \t]*#\\+TBLFM" line) + (when (string-match "^[ \t]*#\\+tblfm" line) (setq recalc t)))) (if recalc (progn (goto-char pos) (org-table-recalculate 'all)) @@ -1337,12 +1364,11 @@ and tailing newline characters." (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) (let ((org-columns-time (time-to-number-of-days (current-time))) - cache maxwidths m p a d fmt) + cache maxwidths m p a d fmt) (cond ((and (boundp 'org-agenda-overriding-columns-format) org-agenda-overriding-columns-format) - (setq fmt org-agenda-overriding-columns-format) - (org-set-local 'org-agenda-overriding-columns-format fmt)) + (setq fmt org-agenda-overriding-columns-format)) ((setq m (org-get-at-bol 'org-hd-marker)) (setq fmt (or (org-entry-get m "COLUMNS" t) (with-current-buffer (marker-buffer m) @@ -1370,7 +1396,7 @@ and tailing newline characters." (setq p (org-entry-properties m)) (when (or (not (setq a (assoc org-effort-property p))) - (not (string-match "\\S-" (or (cdr a) "")))) + (not (string-match "\\S-" (or (cdr a) "")))) ;; OK, the property is not defined. Use appointment duration? (when (and org-agenda-columns-add-appointments-to-effort-sum (setq d (get-text-property (point) 'duration))) @@ -1397,8 +1423,9 @@ and tailing newline characters." "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 (equal (car x) "CLOCKSUM") - (list "CLOCKSUM" (nth 1 x) (nth 2 x) ":" 'add_times + (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)) @@ -1485,23 +1512,25 @@ This will add overlays to the date lines, to show the summary for each day." (goto-char (point-min)) (org-columns-get-format-and-top-level) (while (setq fm (pop fmt)) - (if (equal (car fm) "CLOCKSUM") - (org-clock-sum) - (when (and (nth 4 fm) - (setq a (assoc (car fm) - org-columns-current-fmt-compiled)) - (equal (nth 4 a) (nth 4 fm))) - (org-columns-compute (car fm))))))))))) + (cond ((equal (car fm) "CLOCKSUM") + (org-clock-sum)) + ((equal (car fm) "CLOCKSUM_T") + (org-clock-sum-today)) + ((and (nth 4 fm) + (setq a (assoc (car fm) + org-columns-current-fmt-compiled)) + (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)) + (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) @@ -1519,10 +1548,10 @@ 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 ((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))))) |