;;; org-collector --- collect properties into tables
;;
;;; Eric Schulte
;;
;;; Comments:
;;
;; pass in an alist of columns, each column can be either a single
;; property or a function which takes column as arguments.  Specify a
;; column
;; 
(require 'org)
(require 'org-table)

(defun and-rest (list)
  (if (listp list)
      (if (> (length list) 1)
	  (and (car list) (and-rest (cdr list)))
	(car list))
    list))

(put 'org-collector-error
     'error-conditions
     '(error column-prop-error org-collector-error))

(defun org-read-prop (prop)
  "Convert the string property PROP to a number if appropriate.
Otherwise if prop looks like a list (meaning it starts with a
'(') then read it as lisp, otherwise return it unmodified as a
string."
  (if (stringp prop)
      (if prop
	  (let ((out (string-to-number prop)))
	    (if (equal out 0)
		(if (or (equal "(" (substring prop 0 1)) (equal "'" (substring prop 0 1)))
		    (read prop)
		    (if (string-match "^\\(+0\\|-0\\|0\\)$" prop)
			0
			(progn (set-text-properties 0 (length prop) nil prop)
			       prop)))
		out))
	  nil)
      prop))

(defun org-dblock-write:propview (params)
  "collect the column specification from the #+cols line
preceeding the dblock, then update the contents of the dblock."
  (interactive)
  (condition-case er
      (let ((cols (plist-get params :cols))
	    id table)
	(save-excursion
	  (when (setq id (plist-get params :id))
	    (cond ((not id) nil)
		  ((eq id 'global) (goto-char (point-min)))
		  ((eq id 'local)  nil)
		  ((setq idpos (org-find-entry-with-id id))
		   (goto-char idpos))
		  (t (error "Cannot find entry with :ID: %s" id))))
	  (org-narrow-to-subtree)
	  (setq table (org-propview-to-table (org-propview-collect cols)))
	  (widen))
	(insert table) (org-cycle))
    (org-collector-error (widen) (error "%s" er))
    (error (widen) (error "%s" er))))

(defun org-propview-collect (cols)
  (interactive)
  ;; collect the properties from every header
  (let* ((header-props (org-map-entries (quote (cons (cons "ITEM" (org-get-heading))
						     (org-entry-properties)))))
	 ;; collect all property names
	 (prop-names (mapcar 'intern (delete-dups
				      (apply 'append (mapcar (lambda (header)
							       (mapcar 'car header))
							     header-props))))))
    ;; (message (format "header-props=%S" header-props))
    ;; (message (format "prop-names=%S" prop-names))
    (append
     (list
      ;; create an output list of the headers for each output col
      (mapcar (lambda (el) (format "%S" el)) cols)
      'hline)
     (mapcar ;; for each header's entries
      (lambda (props)
	(mapcar ;;   for each col
	 (lambda (col)
	   (or
	    ;; if col is a symbol and it's present return it's value
	    (and (symbolp col)
		 (let ((val (cdr (assoc (symbol-name col) props))))
		   (if val (org-read-prop val))))
	    ;; if col is a list, and everything in it's cdr is present,
	    ;; then evaluate it as a function
	    (and (listp col)
		 (let ((vals (mapcar (lambda (el) (if (memq el prop-names)
						      (org-read-prop (cdr (assoc (symbol-name el) props)))
						      el))
				     (cdr col))))
		   (message (format "vals-%S" vals))
		   (condition-case col-er
		       (and (and-rest vals) (org-read-prop (eval (cons (car col) vals))))
		     (error (signal 'org-collector-error
				    (list (format "%S while processing: %S" col-er col)))))
		   ))
	    :na)) ;; else return an appropriate default
	 cols))
      header-props))))

(defun org-propview-to-table (results)
  ;; (message (format "cols:%S" cols))
  (orgtbl-to-orgtbl
   (mapcar
    (lambda (row)
      (if (equal row 'hline)
	  'hline
	(mapcar (lambda (el) (format "%S" el)) row)))
    (delq nil results)) '()))

(provide 'org-collector)
;;; org-collector ends here