X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/8d64207425f5345576b77dc9308943ec56ad9327..c6678f2916c22cd3b16232dc941f318c894ef56e:/lisp/org/org-colview.el diff --git a/lisp/org/org-colview.el b/lisp/org/org-colview.el index 3dbb9140d0..683b845c3e 100644 --- a/lisp/org/org-colview.el +++ b/lisp/org/org-colview.el @@ -1,12 +1,12 @@ ;;; org-colview.el --- Column View in Org-mode -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; Free Software Foundation, Inc. ;; Author: Carsten Dominik ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://orgmode.org -;; Version: 6.31a +;; Version: 6.33x ;; ;; This file is part of GNU Emacs. ;; @@ -34,6 +34,7 @@ (require 'org) (declare-function org-agenda-redo "org-agenda" ()) +(declare-function org-agenda-do-context-action "org-agenda" ()) ;;; Column View @@ -91,14 +92,18 @@ This is the compiled version of the format.") (beginning-of-line 2) (while (and (org-invisible-p2) (not (eobp))) (beginning-of-line 2)) - (move-to-column col)))) + (move-to-column col) + (if (eq major-mode 'org-agenda-mode) + (org-agenda-do-context-action))))) (org-defkey org-columns-map [up] (lambda () (interactive) (let ((col (current-column))) (beginning-of-line 0) (while (and (org-invisible-p2) (not (bobp))) (beginning-of-line 0)) - (move-to-column col)))) + (move-to-column col) + (if (eq major-mode 'org-agenda-mode) + (org-agenda-do-context-action))))) (org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value) (org-defkey org-columns-map "n" 'org-columns-next-allowed-value) (org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value) @@ -111,8 +116,8 @@ This is the compiled version of the format.") (org-defkey org-columns-map [(shift meta left)] 'org-columns-delete) (dotimes (i 10) (org-defkey org-columns-map (number-to-string i) - `(lambda () (interactive) - (org-columns-next-allowed-value nil ,i)))) + `(lambda () (interactive) + (org-columns-next-allowed-value nil ,i)))) (easy-menu-define org-columns-menu org-columns-map "Org Column Menu" '("Column" @@ -165,7 +170,7 @@ This is the compiled version of the format.") (face1 (list color 'org-agenda-column-dateline ref-face)) (pl (or (get-text-property (point-at-bol) 'prefix-length) 0)) (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp)) - pom property ass width f string ov column val modval s2 title) + pom property ass width f string ov column val modval s2 title calc) ;; Check if the entry is in another buffer. (unless props (if (eq major-mode 'org-agenda-mode) @@ -189,19 +194,26 @@ This is the compiled version of the format.") (nth 2 column) (length property)) f (format "%%-%d.%ds | " width width) + calc (nth 7 column) val (or (cdr ass) "") - modval (or (and org-columns-modify-value-for-display-function - (functionp - org-columns-modify-value-for-display-function) - (funcall - org-columns-modify-value-for-display-function - title val)) - (if (equal property "ITEM") - (if (org-mode-p) - (org-columns-cleanup-item - val org-columns-current-fmt-compiled) - (org-agenda-columns-cleanup-item - val pl cphr org-columns-current-fmt-compiled))))) + modval (cond ((and org-columns-modify-value-for-display-function + (functionp + org-columns-modify-value-for-display-function)) + (funcall org-columns-modify-value-for-display-function + title val)) + ((equal property "ITEM") + (if (org-mode-p) + (org-columns-cleanup-item + val org-columns-current-fmt-compiled) + (org-agenda-columns-cleanup-item + val pl cphr org-columns-current-fmt-compiled))) + ((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 (nth 4 column))) + (nth 4 column))))) (setq s2 (org-columns-add-ellipses (or modval val) width)) (setq string (format f s2)) ;; Create the overlay @@ -220,18 +232,18 @@ 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))) - (org-overlay-put ov 'invisible t) - (org-overlay-put ov 'keymap org-columns-map) - (org-overlay-put ov 'intangible t) - (push ov org-columns-overlays) - (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) - (org-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))) + (org-overlay-put ov 'invisible t) + (org-overlay-put ov 'keymap org-columns-map) + (org-overlay-put ov 'intangible t) + (push ov org-columns-overlays) + (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) + (org-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"))))) @@ -257,6 +269,7 @@ for the duration of the command.") (defvar header-line-format) (defvar org-columns-previous-hscroll 0) + (defun org-columns-display-here-title () "Overlay the newline before the current line with the table title." (interactive) @@ -347,6 +360,7 @@ for the duration of the command.") s) (defvar org-agenda-columns-remove-prefix-from-item) + (defun org-agenda-columns-cleanup-item (item pl cphr fmt) "Cleanup the time property for agenda column view. See also the variable `org-agenda-columns-remove-prefix-from-item'." @@ -366,6 +380,7 @@ See also the variable `org-agenda-columns-remove-prefix-from-item'." (message "Value is: %s" (or value "")))) (defvar org-agenda-columns-active) ;; defined in org-agenda.el + (defun org-columns-quit () "Remove the column overlays and in this way exit column editing." (interactive) @@ -417,6 +432,7 @@ Where possible, use the standard interface for changing this line." (<= (overlay-start x) eol) x)) org-columns-overlays))) + (org-columns-time (time-to-number-of-days (current-time))) nval eval allowed) (cond ((equal key "CLOCKSUM") @@ -661,7 +677,8 @@ around it." (org-verify-version 'columns) (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) - (let (beg end fmt cache maxwidths) + (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)) (save-excursion (goto-char org-columns-top-level-marker) @@ -678,7 +695,7 @@ around it." (narrow-to-region beg end) (org-clock-sum)))) (while (re-search-forward (concat "^" outline-regexp) end t) - (if (and org-columns-skip-arrchived-trees + (if (and org-columns-skip-archived-trees (looking-at (concat ".*:" org-archive-tag ":"))) (org-end-of-subtree t) (push (cons (org-current-line) (org-entry-properties)) cache))) @@ -698,23 +715,43 @@ around it." (org-columns-display-here (cdr x))) cache))))) +(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)))))) - "Operator <-> format,function 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)))) + "Operator <-> format,function,calc map. Used to compile/uncompile columns format and completing read in -interactive function org-columns-new.") +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." @@ -735,7 +772,7 @@ interactive function org-columns-new.") org-columns-compile-map) nil t)) (setq fmt (intern fmt) - fun (cadr (assoc fmt (mapcar 'cdr org-columns-compile-map)))) + fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map)))) (if (eq fmt 'none) (setq fmt nil)) (if editp (progn @@ -743,7 +780,8 @@ interactive function org-columns-new.") (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 fun) + (setcdr cell (cons (list prop title width nil fmt nil + (car fun) (cadr fun)) (cdr cell)))) (org-columns-store-format) (org-columns-redo))) @@ -860,7 +898,9 @@ Don't set this, this is meant for dynamic scoping.") "Compute all columns that have operators defined." (org-unmodified (remove-text-properties (point-min) (point-max) '(org-summaries t))) - (let ((columns org-columns-current-fmt-compiled) col) + (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 @@ -895,6 +935,7 @@ Don't set this, this is meant for dynamic scoping.") (format (nth 4 ass)) (printf (nth 5 ass)) (fun (nth 6 ass)) + (calc (or (nth 7 ass) 'identity)) (beg org-columns-top-level-marker) last-level val valflag flag end sumpos sum-alist sum str str1 useval) (save-excursion @@ -927,10 +968,12 @@ Don't set this, this is meant for dynamic scoping.") (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 + ;; add current to current level accumulator (when (or flag valflag) - (push (if flag sum - (org-column-string-to-number (if flag str val) format)) + (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 @@ -940,8 +983,8 @@ Don't set this, this is meant for dynamic scoping.") ((>= level last-level) ;; add what we have here to the accumulator for this level (when valflag - (push (org-column-string-to-number val format) - (aref lvals level)) + (push (funcall calc (org-columns-string-to-number val format)) + (aref lvals level)) (aset lflag level t))) (t (error "This should not happen"))))))) @@ -967,7 +1010,6 @@ Don't set this, this is meant for dynamic scoping.") (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)) @@ -994,6 +1036,8 @@ Don't set this, this is meant for dynamic scoping.") (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) @@ -1001,21 +1045,33 @@ Don't set this, this is meant for dynamic scoping.") (format "[%d/%d]" n m) (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m))))))) -(defun org-column-string-to-number (s fmt) +(defun org-columns-string-to-number (s fmt) "Convert a column value to a number that can be used for column computing." - (cond - ((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)) - (t (string-to-number s)))) + (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)) + (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) + (let ((rtn "") e s prop title op op-match width fmt printf fun calc) (while (setq e (pop cfmt)) (setq prop (car e) title (nth 1 e) @@ -1023,8 +1079,9 @@ Don't set this, this is meant for dynamic scoping.") op (nth 3 e) fmt (nth 4 e) printf (nth 5 e) - fun (nth 6 e)) - (when (setq op-match (rassoc (list fmt fun) org-columns-compile-map)) + fun (nth 6 e) + calc (nth 7 e)) + (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map)) (setq op (car op-match))) (if (and op printf) (setq op (concat op ";" printf))) (if (equal title prop) (setq title nil)) @@ -1045,8 +1102,10 @@ 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 values, derived from operator" - (let ((start 0) width prop title op op-match f printf fun) +fun the lisp function to compute summary values, derived from operator +calc function to get values from base elements +" + (let ((start 0) width prop title op op-match f printf fun calc) (setq org-columns-current-fmt-compiled nil) (while (string-match (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*") @@ -1058,15 +1117,18 @@ fun the lisp function to compute values, derived from operator" op (match-string 4 fmt) f nil printf nil - fun '+) + 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))) - (push (list prop title width op f printf fun) org-columns-current-fmt-compiled)) + fun (caddr op-match) + calc (cadddr op-match))) + (push (list prop title width op f printf fun calc) + org-columns-current-fmt-compiled)) (setq org-columns-current-fmt-compiled (nreverse org-columns-current-fmt-compiled)))) @@ -1121,18 +1183,18 @@ PARAMS is a property list of parameters: :width enforce same column widths with 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 - 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'. + 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. + a hline before each level <= that number. :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." (let ((pos (move-marker (make-marker) (point))) (hlines (plist-get params :hlines)) (vlines (plist-get params :vlines)) @@ -1253,7 +1315,8 @@ and tailing newline characters." (org-verify-version 'columns) (org-columns-remove-overlays) (move-marker org-columns-begin-marker (point)) - (let (fmt cache maxwidths m p a d) + (let ((org-columns-time (time-to-number-of-days (current-time))) + cache maxwidths m p a d fmt) (cond ((and (boundp 'org-agenda-overriding-columns-format) org-agenda-overriding-columns-format) @@ -1313,10 +1376,11 @@ 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) - (list (car x) (if (equal (car x) "CLOCKSUM") - 'add_times (nth 4 x)))) + (if (equal (car x) "CLOCKSUM") + (list "CLOCKSUM" (nth 2 x) nil 'add_times nil '+ 'identity) + (cdr x))) org-columns-current-fmt-compiled)) - line c c1 stype props lsum entries prop v) + line c c1 stype calc sumfunc props lsum entries prop v) (catch 'exit (when (delq nil (mapcar 'cadr fmt)) ;; OK, at least one summation column, it makes sense to try this @@ -1339,24 +1403,40 @@ This will add overlays to the date lines, to show the summary for each day." (setq props (mapcar (lambda (f) - (setq prop (car f) stype (nth 1 f)) + (setq prop (car f) + stype (nth 3 f) + sumfunc (nth 5 f) + calc (or (nth 6 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 0) - (mapc (lambda (x) - (setq v (cdr (assoc prop x))) - (if v (setq lsum (+ lsum - (org-column-string-to-number - v stype))))) - entries) - (setq lsum (org-columns-number-to-string lsum stype)) - (put-text-property - 0 (length lsum) 'face 'bold lsum) + (t ;; do the summary + (setq lsum nil) + (dolist (x entries) + (setq v (cdr (assoc prop x))) + (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) @@ -1390,6 +1470,18 @@ This will add overlays to the date lines, to show the summary for each day." (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)) + "")) + + (provide 'org-colview) ;; arch-tag: 61f5128d-747c-4983-9479-e3871fa3d73c