Apply the changes made to org-colview.el to org-colview-xemacs.el

lisp/ChangeLog

@@ -53,6 +53,10 @@
 	org-return-follows-link' is set and there is nothing else to do in
 	this line.
 
+2009-11-02  James TD Smith  <ahktenzero@mohorovi.cc>
+
+	* org-colview-xemacs.el: Add in changes from org-colview.el
+
 2009-11-01  Dan Davison  <davison@stats.ox.ac.uk>
 
 	* org-exp-blocks.el: Modify split separator regexp to avoid empty

lisp/org-colview-xemacs.el

@@ -324,7 +324,7 @@ This is the compiled version of the format.")
 	 (face (if (featurep 'xemacs) color (list color 'org-column)))
 	 (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)
@@ -345,18 +345,24 @@ This is the compiled version of the format.")
 	    f (format (if (featurep 'xemacs) "%%-%d.%ds |" "%%-%d.%ds | ")
 		      width width)
 	    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)))))
+	    calc (nth 7 column)
+	    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 (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
@@ -424,6 +430,7 @@ This is the compiled version of the format.")
 
 (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)
@@ -526,6 +533,7 @@ This is the compiled version of the format.")
   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'."
@@ -545,6 +553,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)
@@ -596,6 +605,7 @@ Where possible, use the standard interface for changing this line."
 				   (<= (org-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")
@@ -845,7 +855,8 @@ around it."
 			 (face-background 'org-columns-space)))
   (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)
@@ -862,7 +873,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)))
@@ -880,29 +891,50 @@ 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,fuction map.
-Used to compile/uncompile columns format and completing read in
-interactive function org-columns-new.")
+  '(("none" none + identity)
+    (":" add_times + identity)
+    ("+" add_numbers + identity)
+    ("$" currency + identity)
+    ("X" checkbox + identity)
+    ("X/" checkbox-n-of-m + identity)
+    ("X%" checkbox-percent + identity)
+    ("max" max_numbers max identity)
+    ("min" min_numbers min identity)
+    ("mean" mean_numbers
+     (lambda (&rest x) (/ (apply '+ x) (float (length x))))
+     identity)
+    (":max" max_times max identity)
+    (":min" min_times min identity)
+    (":mean" mean_times
+     (lambda (&rest x) (/ (apply '+ x) (float (length x))))
+     identity)
+    ("@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.
+
+ 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")
 
 (defun org-columns-new (&optional prop title width op fmt fun &rest rest)
   "Insert a new column, to the left of the current column."
   (interactive)
   (let ((n (org-columns-current-column))
-        (editp (and prop (assoc prop org-columns-current-fmt-compiled)))
+	(editp (and prop (assoc prop org-columns-current-fmt-compiled)))
 	cell)
     (setq prop (org-icompleting-read
 		"Property: " (mapcar 'list (org-buffer-property-keys t nil t))
@@ -916,14 +948,15 @@ interactive function org-columns-new.")
 				       (mapcar (lambda (x) (list (symbol-name (cadr x)))) 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
 	  (setcar editp prop)
 	  (setcdr editp (list title width nil fmt nil fun)))
       (setq cell (nthcdr (1- n) 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)))
@@ -1041,7 +1074,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
@@ -1080,6 +1115,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
@@ -1112,10 +1148,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
@@ -1125,8 +1163,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")))))))
 
@@ -1152,7 +1190,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))
@@ -1179,6 +1216,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)
@@ -1186,21 +1225,27 @@ 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))
+	(if (string= s "")
+	    org-columns-time
+	  (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)))
+    0))
 
 (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)
@@ -1208,8 +1253,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))
@@ -1230,8 +1276,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-*")
@@ -1243,15 +1291,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))))
 
@@ -1468,7 +1519,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)
@@ -1563,7 +1615,7 @@ This will add overlays to the date lines, to show the summary for each day."
 			 (mapc (lambda (x)
 				 (setq v (cdr (assoc prop x)))
 				 (if v (setq lsum (+ lsum
-						     (org-column-string-to-number
+						     (org-columns-string-to-number
 						      v stype)))))
 			       entries)
 			 (setq lsum (org-columns-number-to-string lsum stype))
@@ -1602,8 +1654,19 @@ 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)
 (provide 'org-colview-xemacs)
 
 ;;; org-colview-xemacs.el ends here
-