mirrors
/
org-mode
mirror of https://git.savannah.gnu.org/git/emacs/org-mode.git
0
0
Fork 1
Code Releases Activity

ox: Speed-up some tools on tables 

* lisp/ox.el (org-export-table-has-special-column-p): Tiny
  refactoring.
(org-export-table-has-header-p): Fix cache use, i.e., no longer
re-compute return value when the table is already known to have no
header.
(org-export-table-row-group):
(org-export-table-row-number): Populate cache with all the rows
whenever a row is queried.  This fixes previous quadratic behaviour.

Reported-by: Thierry Banel <tbanelwebmin@free.fr>
<http://permalink.gmane.org/gmane.emacs.orgmode/111131>
This commit is contained in:
Nicolas Goaziou 2017-01-01 23:58:29 +01:00
parent a277fd3efa
commit 2f5cd67357
2 changed files with 78 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
lisp/ox.el
View File

@ -4747,19 +4747,20 @@ code."
All special columns will be ignored during export."
;; The table has a special column when every first cell of every row
;; has an empty value or contains a symbol among "/", "#", "!", "$",
;; "*" "_" and "^". Though, do not consider a first row containing
;; only empty cells as special.
(let ((special-column-p 'empty))
;; "*" "_" and "^". Though, do not consider a first column
;; containing only empty cells as special.
(let ((special-column? 'empty))
(catch 'exit
(dolist (row (org-element-contents table))
(when (eq (org-element-property :type row) 'standard)
(let ((value (org-element-contents
(car (org-element-contents row)))))
(cond ((member value '(("/") ("#") ("!") ("$") ("*") ("_") ("^")))
(setq special-column-p 'special))
((not value))
(cond ((member value
'(("/") ("#") ("!") ("$") ("*") ("_") ("^")))
(setq special-column? 'special))
((null value))
(t (throw 'exit nil))))))
(eq special-column-p 'special))))
(eq special-column? 'special))))
(defun org-export-table-has-header-p (table info)
"Non-nil when TABLE has a header.
@ -4767,25 +4768,28 @@ All special columns will be ignored during export."
INFO is a plist used as a communication channel.
A table has a header when it contains at least two row groups."
(let ((cache (or (plist-get info :table-header-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-header-cache table)
table))))
(or (gethash table cache)
(let ((rowgroup 1) row-flag)
(puthash
table
(org-element-map table 'table-row
(lambda (row)
(cond
((> rowgroup 1) t)
((and row-flag (eq (org-element-property :type row) 'rule))
(cl-incf rowgroup) (setq row-flag nil))
((and (not row-flag) (eq (org-element-property :type row)
'standard))
(setq row-flag t) nil)))
info 'first-match)
cache)))))
(let* ((cache (or (plist-get info :table-header-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-header-cache table)
table)))
(cached (gethash table cache 'no-cache)))
(if (not (eq cached 'no-cache)) cached
(let ((rowgroup 1) row-flag)
(puthash table
(org-element-map table 'table-row
(lambda (row)
(cond
((> rowgroup 1) t)
((and row-flag
(eq (org-element-property :type row) 'rule))
(cl-incf rowgroup)
(setq row-flag nil))
((and (not row-flag)
(eq (org-element-property :type row) 'standard))
(setq row-flag t)
nil)))
info 'first-match)
cache)))))
(defun org-export-table-row-is-special-p (table-row _)
"Non-nil if TABLE-ROW is considered special.
@ -4826,20 +4830,24 @@ INFO is a plist used as the communication channel.
Return value is the group number, as an integer, or nil for
special rows and rows separators. First group is also table's
header."
(let ((cache (or (plist-get info :table-row-group-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-row-group-cache table)
table))))
(cond ((gethash table-row cache))
((eq (org-element-property :type table-row) 'rule) nil)
(t (let ((group 0) row-flag)
(org-element-map (org-export-get-parent table-row) 'table-row
(lambda (row)
(if (eq (org-element-property :type row) 'rule)
(setq row-flag nil)
(unless row-flag (cl-incf group) (setq row-flag t)))
(when (eq table-row row) (puthash table-row group cache)))
info 'first-match))))))
(when (eq (org-element-property :type table-row) 'standard)
(let* ((cache (or (plist-get info :table-row-group-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-row-group-cache table)
table)))
(cached (gethash table-row cache 'no-cache)))
(if (not (eq cached 'no-cache)) cached
;; First time a row is queried, populate cache with all the
;; rows from the table.
(let ((group 0) row-flag)
(org-element-map (org-export-get-parent table-row) 'table-row
(lambda (row)
(if (eq (org-element-property :type row) 'rule)
(setq row-flag nil)
(unless row-flag (cl-incf group) (setq row-flag t))
(puthash row group cache)))
info))
(gethash table-row cache)))))
(defun org-export-table-cell-width (table-cell info)
"Return TABLE-CELL contents width.
@ -5102,26 +5110,24 @@ INFO is a plist used as a communication channel."
(defun org-export-table-row-number (table-row info)
"Return TABLE-ROW number.
INFO is a plist used as a communication channel. Return value is
zero-based and ignores separators. The function returns nil for
special columns and separators."
(let* ((cache (or (plist-get info :table-row-number-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-row-number-cache table)
table)))
(cached (gethash table-row cache 'no-cache)))
(if (not (eq cached 'no-cache)) cached
(puthash table-row
(and (eq (org-element-property :type table-row) 'standard)
(not (org-export-table-row-is-special-p table-row info))
(let ((number 0))
(org-element-map (org-export-get-parent-table table-row)
'table-row
(lambda (row)
(cond ((eq row table-row) number)
((eq (org-element-property :type row) 'standard)
(cl-incf number) nil)))
info 'first-match)))
cache))))
zero-indexed and ignores separators. The function returns nil
for special rows and separators."
(when (eq (org-element-property :type table-row) 'standard)
(let* ((cache (or (plist-get info :table-row-number-cache)
(let ((table (make-hash-table :test #'eq)))
(plist-put info :table-row-number-cache table)
table)))
(cached (gethash table-row cache 'no-cache)))
(if (not (eq cached 'no-cache)) cached
;; First time a row is queried, populate cache with all the
;; rows from the table.
(let ((number -1))
(org-element-map (org-export-get-parent-table table-row) 'table-row
(lambda (row)
(when (eq (org-element-property :type row) 'standard)
(puthash row (cl-incf number) cache)))
info))
(gethash table-row cache)))))
(defun org-export-table-dimensions (table info)
"Return TABLE dimensions.

24
testing/lisp/test-ox.el
View File

@ -3676,37 +3676,37 @@ Another text. (ref:text)
(ert-deftest test-org-export/has-header-p ()
"Test `org-export-table-has-header-p' specifications."
;; 1. With an header.
(org-test-with-parsed-data "
;; With an header.
(should
(org-test-with-parsed-data "
| a | b |
|---+---|
| c | d |"
(should
(org-export-table-has-header-p
(org-element-map tree 'table 'identity info 'first-match)
info)))
;; 2. Without an header.
(org-test-with-parsed-data "
;; Without an header.
(should-not
(org-test-with-parsed-data "
| a | b |
| c | d |"
(should-not
(org-export-table-has-header-p
(org-element-map tree 'table 'identity info 'first-match)
info)))
;; 3. Don't get fooled with starting and ending rules.
(org-test-with-parsed-data "
;; Don't get fooled with starting and ending rules.
(should-not
(org-test-with-parsed-data "
|---+---|
| a | b |
| c | d |
|---+---|"
(should-not
(org-export-table-has-header-p
(org-element-map tree 'table 'identity info 'first-match)
info))))
(ert-deftest test-org-export/table-row-group ()
"Test `org-export-table-row-group' specifications."
;; 1. A rule creates a new group.
;; A rule creates a new group.
(should
(equal '(1 rule 2)
(org-test-with-parsed-data "
@ -3717,7 +3717,7 @@ Another text. (ref:text)
(lambda (row)
(if (eq (org-element-property :type row) 'rule) 'rule
(org-export-table-row-group row info)))))))
;; 2. Special rows are ignored in count.
;; Special rows are ignored in count.
(should
(equal
'(rule 1)
@ -3730,7 +3730,7 @@ Another text. (ref:text)
(if (eq (org-element-property :type row) 'rule) 'rule
(org-export-table-row-group row info)))
info))))
;; 3. Double rules also are ignored in count.
;; Double rules also are ignored in count.
(should
(equal '(1 rule rule 2)
(org-test-with-parsed-data "