summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-14 14:06:32 +0100
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2016-02-17 22:49:19 +0100
commit470f9fae08f590a65fdf38f038940323a220aaf2 (patch)
treeb5910dc0914f948d0d8ceeb794588343ce707ee3
parent23f111904207c9a489245ad66df16af031079978 (diff)
downloadorg-mode-470f9fae08f590a65fdf38f038940323a220aaf2.tar.gz
org-colview: Fix capture view
* lisp/org-colview.el (org-columns-capture-view): Rename to... (org-columns--capture-view): ... this. (org-dblock-write:columnview): Fix produced table according to new column view internals. * lisp/org-colview.el (org-columns--clean-item): New function. (org-listtable-to-string): Remove function.
-rw-r--r--lisp/org-colview.el283
1 files changed, 141 insertions, 142 deletions
diff --git a/lisp/org-colview.el b/lisp/org-colview.el
index f5de4d0..0e90925 100644
--- a/lisp/org-colview.el
+++ b/lisp/org-colview.el
@@ -1181,51 +1181,70 @@ This function updates `org-columns-current-fmt-compiled'."
(nreverse org-columns-current-fmt-compiled))))
+
;;; Dynamic block for Column view
-(defun org-columns-capture-view (&optional maxlevel skip-empty-rows)
- "Get the column view of the current buffer or subtree.
-The first optional argument MAXLEVEL sets the level limit.
-A second optional argument SKIP-EMPTY-ROWS tells whether to skip
+(defun org-columns--capture-view (maxlevel skip-empty 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. This function returns a list
-containing the title row and all other rows. Each row is a list
-of fields."
- (save-excursion
- (let* ((title (mapcar #'cadr org-columns-current-fmt-compiled))
- (has-item? (assoc-string "ITEM" org-columns-current-fmt-compiled t))
- (n (length title))
- tbl)
- (goto-char (point-min))
- (while (re-search-forward org-outline-regexp-bol nil t)
- (catch 'next
- (when (and (or (null maxlevel)
- (>= maxlevel (org-reduced-level (org-outline-level))))
- (get-char-property (match-beginning 0) 'org-columns-key))
- (when (or (org-in-commented-heading-p t)
- (member org-archive-tag (org-get-tags)))
- (org-end-of-subtree t)
- (throw 'next t))
- (let (row)
- (dotimes (i n)
- (let ((col (+ (line-beginning-position) i)))
- (push (org-quote-vert
- (or (get-char-property col 'org-columns-value-modified)
- (get-char-property col 'org-columns-value)
- ""))
- row)))
- (unless (and skip-empty-rows
- (let ((r (delete-dups (remove "" row))))
- (or (null r) (and has-item? (= (length r) 1)))))
- (push (nreverse row) tbl))))))
- (append (list title 'hline) (nreverse tbl)))))
+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.
+
+This function returns a list containing the title row and all
+other rows. Each row is a list of fields, as strings, or
+`hline'."
+ (org-columns (not local) format)
+ (goto-char org-columns-top-level-marker)
+ (let ((columns (length org-columns-current-fmt-compiled))
+ (has-item (assoc-string "ITEM" org-columns-current-fmt-compiled t))
+ table)
+ (org-map-entries
+ (lambda ()
+ (when (get-char-property (point) 'org-columns-key)
+ (let (row)
+ (dotimes (i columns)
+ (let* ((col (+ (line-beginning-position) i))
+ (p (get-char-property col 'org-columns-key)))
+ (push (org-quote-vert
+ (get-char-property col
+ (if (string= (upcase p) "ITEM")
+ '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)))))
+ (push (cons (org-reduced-level (org-current-level)) (nreverse row))
+ table)))))
+ (and maxlevel (format "LEVEL<=%d" maxlevel))
+ (and local 'tree)
+ 'archive 'comment)
+ (org-columns-quit)
+ ;; Add column titles and a horizontal rule in front of the table.
+ (cons (mapcar #'cadr org-columns-current-fmt-compiled)
+ (cons 'hline (nreverse table)))))
+
+(defun org-columns--clean-item (item)
+ "Remove sensitive contents from string ITEM.
+This includes objects that may not be duplicated within
+a document, e.g., a target, or those forbidden in tables, e.g.,
+an inline src-block."
+ (let ((data (org-element-parse-secondary-string
+ item (org-element-restriction 'headline))))
+ (org-element-map data
+ '(footnote-reference inline-babel-call inline-src-block target
+ radio-target statistics-cookie)
+ #'org-element-extract-element)
+ (org-no-properties (org-element-interpret-data data))))
;;;###autoload
(defun org-dblock-write:columnview (params)
"Write the column view table.
PARAMS is a property list of parameters:
-:width enforce same column widths with <N> 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
@@ -1235,126 +1254,104 @@ PARAMS is a property list of parameters:
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."
- (let ((pos (point-marker))
- (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 recalc line
- id-as-string view-file view-pos)
- (when (setq id (plist-get params :id))
- (setq id-as-string (cond ((numberp id) (number-to-string id))
- ((symbolp id) (symbol-name id))
- ((stringp id) id)
- (t "")))
- (cond ((not id) nil)
- ((eq id 'global) (setq view-pos (point-min)))
- ((eq id 'local))
- ((string-match "^file:\\(.*\\)" id-as-string)
- (setq view-file (match-string 1 id-as-string)
- view-pos 1)
- (unless (file-exists-p view-file)
- (error "No such file: \"%s\"" id-as-string)))
- ((setq idpos (org-find-entry-with-id id))
- (setq view-pos idpos))
- ((setq idpos (org-id-find id))
- (setq view-file (car idpos))
- (setq view-pos (cdr idpos)))
- (t (error "Cannot find entry with :ID: %s" id))))
- (with-current-buffer (if view-file
- (get-file-buffer view-file)
- (current-buffer))
- (org-with-wide-buffer
- (goto-char (or view-pos (point)))
- (org-columns columns-fmt)
- (setq tbl (org-columns-capture-view maxlevel skip-empty-rows))
- (setq nfields (length (car tbl)))
- (org-columns-quit)))
- (goto-char pos)
- (move-marker pos nil)
- (when tbl
- ;; Normalize headings in the table. Remove stars, add
- ;; indentation entities, if required, and possibly precede some
- ;; of them with a horizontal rule.
+ (let ((table
+ (let ((id (plist-get params :id))
+ view-file view-pos)
+ (pcase id
+ (`global nil)
+ ((or `local `nil) (setq view-pos (point)))
+ ((and (let id-string (format "%s" id))
+ (guard (string-match "^file:\\(.*\\)" id-string)))
+ (setq view-file (match-string-no-properties 1 id-string))
+ (unless (file-exists-p view-file)
+ (user-error "No such file: %S" id-string)))
+ ((and (let idpos (org-find-entry-with-id id)) idpos)
+ (setq view-pos idpos))
+ ((let `(,filename . ,position) (org-id-find id))
+ (setq view-file filename)
+ (setq view-pos position))
+ (_ (user-error "Cannot find entry with :ID: %s" id)))
+ (with-current-buffer (if view-file (get-file-buffer view-file)
+ (current-buffer))
+ (org-with-wide-buffer
+ (when view-pos (goto-char view-pos))
+ (org-columns--capture-view (plist-get params :maxlevel)
+ (plist-get params :skip-empty-rows)
+ (plist-get params :format)
+ view-pos))))))
+ (when table
+ ;; Prune level information from the table. Also normalize
+ ;; headings: remove stars, add indentation entities, if
+ ;; required, and possibly precede some of them with a horizontal
+ ;; rule.
(let ((item-index
(let ((p (assoc-string "ITEM" org-columns-current-fmt-compiled t)))
(and p (cl-position p
org-columns-current-fmt-compiled
:test #'equal))))
(hlines (plist-get params :hlines))
- (indent (plist-get params :indent)))
- (when item-index
- (let (new-table)
- ;; Copy header and first rule.
- (push (pop tbl) new-table)
- (push (pop tbl) new-table)
- (while tbl
- (let ((row (car tbl)))
- (if (eq row 'hline)
- (push (pop tbl) new-table)
- (let* ((item (nth item-index row))
- (level (and (string-match "\\`\\( *\\*+\\) +" item)
- ;; Leading white spaces are
- ;; actually stars made invisible
- ;; (see `org-columns') so they
- ;; add up to heading level.
- (org-reduced-level
- (- (match-end 1) (match-beginning 1))))))
- (when (and (not (eq (car new-table) 'hline))
- (or (eq hlines t)
- (and (numberp hlines) (<= level hlines))))
- (push 'hline new-table))
- (setf (nth item-index row)
- (replace-match
- (if (or (not indent) (= level 1)) ""
- (concat "\\\\_"
- (make-string (* 2 (1- level)) ?\s)))
- nil nil item))
- (push (pop tbl) new-table)))))
- (setq tbl (nreverse new-table)))))
- (when vlines
- (setq tbl (mapcar (lambda (x)
- (if (eq 'hline x) x (cons "" x)))
- tbl))
- (setq tbl (append tbl (list (cons "/" (make-list nfields "<>"))))))
- (when content-lines
- (while (string-match "^#" (car content-lines))
- (insert (pop content-lines) "\n")))
- (setq pos (point))
- (insert (org-listtable-to-string tbl))
+ (indent (plist-get params :indent))
+ new-table)
+ ;; Copy header and first rule.
+ (push (pop table) new-table)
+ (push (pop table) new-table)
+ (dolist (row table (setq table (nreverse new-table)))
+ (let ((level (car row)))
+ (when (and (not (eq (car new-table) 'hline))
+ (or (eq hlines t)
+ (and (numberp hlines) (<= level hlines))))
+ (push 'hline new-table))
+ (when item-index
+ (let ((item (org-columns--clean-item (nth item-index (cdr row)))))
+ (setf (nth item-index (cdr row))
+ (if (and indent (> level 1))
+ (concat "\\_" (make-string (* 2 (1- level)) ?\s) item)
+ item))))
+ (push (cdr row) new-table))))
(when (plist-get params :width)
- (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x)))
- org-columns-current-maxwidths "|")))
- (while (setq line (pop content-lines))
- (when (string-match "^#" line)
- (insert "\n" line)
- (when (string-match "^[ \t]*#\\+tblfm" line)
- (setq recalc t))))
- (if recalc
- (progn (goto-char pos) (org-table-recalculate 'all))
- (goto-char pos)
+ (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)))
+ (append (mapcar (lambda (x) (if (eq 'hline x) x (cons "" x)))
+ table)
+ (list (cons "/" (make-list size "<>")))))))
+ (let ((content-lines (org-split-string (plist-get params :content) "\n"))
+ recalc)
+ ;; Insert affiliated keywords before the table.
+ (when content-lines
+ (while (string-match-p "\\`[ \t]*#\\+" (car content-lines))
+ (insert (pop content-lines) "\n")))
+ (save-excursion
+ ;; Insert table at point.
+ (insert
+ (mapconcat (lambda (row)
+ (if (eq row 'hline) "|-|"
+ (format "|%s|" (mapconcat #'identity row "|"))))
+ table
+ "\n"))
+ ;; Insert TBLFM lines following table.
+ (let ((case-fold-search t))
+ (dolist (line content-lines)
+ (when (string-match-p "\\`[ \t]*#\\+TBLFM:" line)
+ (insert "\n" line)
+ (unless recalc (setq recalc t))))))
+ (when recalc (org-table-recalculate 'all t))
(org-table-align)))))
-(defun org-listtable-to-string (tbl)
- "Convert a listtable TBL to a string that contains the Org-mode table.
-The table still need to be aligned. The resulting string has no leading
-and tailing newline characters."
- (mapconcat
- (lambda (x)
- (cond
- ((listp x)
- (concat "|" (mapconcat 'identity x "|") "|"))
- ((eq x 'hline) "|-|")
- (t (error "Garbage in listtable: %s" x))))
- tbl "\n"))
-
;;;###autoload
(defun org-insert-columns-dblock ()
"Create a dynamic block capturing a column view table."
@@ -1370,6 +1367,8 @@ and tailing newline characters."
(org-create-dblock defaults)
(org-update-dblock)))
+
+
;;; Column view in the agenda
;;;###autoload