From 62296ceb8879efb4cd76ed3e00e8047ccf30777b Mon Sep 17 00:00:00 2001 From: Nicolas Goaziou Date: Sat, 18 May 2013 18:20:46 +0200 Subject: [PATCH] ox: Improve speed wrt table export * lisp/ox.el (org-export-resolve-fuzzy-link): Change property name holding cache. (org-export-table-has-header-p, org-export-table-row-group, org-export-table-cell-width, org-export-table-cell-alignment): Cache results. (org-export-table-cell-address): Refactor. (org-export-get-parent): Inline function. * testing/lisp/test-ox.el: Update tests. --- lisp/ox.el | 250 ++++++++++++++++++++++++++---------------------- testing/lisp/test-ox.el | 41 ++++---- 2 files changed, 157 insertions(+), 134 deletions(-) diff --git a/lisp/ox.el b/lisp/ox.el index 36c35a836..76f3df9eb 100644 --- a/lisp/ox.el +++ b/lisp/ox.el @@ -3989,10 +3989,10 @@ significant." (if match-title-p (substring raw-path 1) raw-path))) ;; Cache for destinations that are not position dependent. (link-cache - (or (plist-get info :fuzzy-link-cache) - (plist-get (setq info (plist-put info :fuzzy-link-cache + (or (plist-get info :resolve-fuzzy-link-cache) + (plist-get (setq info (plist-put info :resolve-fuzzy-link-cache (make-hash-table :test 'equal))) - :fuzzy-link-cache))) + :resolve-fuzzy-link-cache))) (cached (gethash path link-cache 'not-found))) (cond ;; Destination is not position dependent: use cached value. @@ -4384,16 +4384,26 @@ 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 ((rowgroup 1) row-flag) - (org-element-map table 'table-row - (lambda (row) - (cond - ((> rowgroup 1) t) - ((and row-flag (eq (org-element-property :type row) 'rule)) - (incf rowgroup) (setq row-flag nil)) - ((and (not row-flag) (eq (org-element-property :type row) 'standard)) - (setq row-flag t) nil))) - info))) + (let ((cache (or (plist-get info :table-header-cache) + (plist-get (setq info + (plist-put info :table-header-cache + (make-hash-table :test 'eq))) + :table-header-cache)))) + (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)) + (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 info) "Non-nil if TABLE-ROW is considered special. @@ -4432,26 +4442,28 @@ All special rows will be ignored during export." (eq special-row-p 'cookie))))))) (defun org-export-table-row-group (table-row info) - "Return TABLE-ROW's group. + "Return TABLE-ROW's group number, as an integer. INFO is a plist used as the communication channel. Return value is the group number, as an integer, or nil for -special rows and table rules. Group 1 is also table's header." - (unless (or (eq (org-element-property :type table-row) 'rule) - (org-export-table-row-is-special-p table-row info)) - (let ((group 0) row-flag) - (catch 'found - (mapc - (lambda (row) - (cond - ((and (eq (org-element-property :type row) 'standard) - (not (org-export-table-row-is-special-p row info))) - (unless row-flag (incf group) (setq row-flag t))) - ((eq (org-element-property :type row) 'rule) - (setq row-flag nil))) - (when (eq table-row row) (throw 'found group))) - (org-element-contents (org-export-get-parent table-row))))))) +special rows and rows separators. First group is also table's +header." + (let ((cache (or (plist-get info :table-row-group-cache) + (plist-get (setq info + (plist-put info :table-row-group-cache + (make-hash-table :test 'eq))) + :table-row-group-cache)))) + (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 (incf group) (setq row-flag t))) + (when (eq table-row row) (puthash table-row group cache))) + info 'first-match)))))) (defun org-export-table-cell-width (table-cell info) "Return TABLE-CELL contents width. @@ -4461,31 +4473,34 @@ INFO is a plist used as the communication channel. Return value is the width given by the last width cookie in the same column as TABLE-CELL, or nil." (let* ((row (org-export-get-parent table-cell)) + (table (org-export-get-parent row)) (column (let ((cells (org-element-contents row))) (- (length cells) (length (memq table-cell cells))))) - (table (org-export-get-parent-table table-cell)) - cookie-width) - (mapc - (lambda (row) - (cond - ;; In a special row, try to find a width cookie at COLUMN. - ((org-export-table-row-is-special-p row info) - (let ((value (org-element-contents - (elt (org-element-contents row) column)))) - ;; The following checks avoid expanding unnecessarily the - ;; cell with `org-export-data' - (when (and value - (not (cdr value)) - (stringp (car value)) - (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" (car value)) - (match-string 1 (car value))) - (setq cookie-width - (string-to-number (match-string 1 (car value))))))) - ;; Ignore table rules. - ((eq (org-element-property :type row) 'rule)))) - (org-element-contents table)) - ;; Return value. - cookie-width)) + (cache (or (plist-get info :table-cell-width-cache) + (plist-get (setq info + (plist-put info :table-cell-width-cache + (make-hash-table :test 'equal))) + :table-cell-width-cache))) + (key (cons table column))) + (or (let ((cached (gethash key cache 'no-result))) + (and (not (eq cached 'no-result)) cached)) + (let (cookie-width) + (dolist (row (org-element-contents table) + (puthash key cookie-width cache)) + (when (org-export-table-row-is-special-p row info) + ;; In a special row, try to find a width cookie at COLUMN. + (let* ((value (org-element-contents + (elt (org-element-contents row) column))) + (cookie (car value))) + ;; The following checks avoid expanding unnecessarily the + ;; cell with `org-export-data' + (when (and value + (not (cdr value)) + (stringp cookie) + (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" cookie) + (match-string 1 cookie)) + (setq cookie-width + (string-to-number (match-string 1 cookie))))))))))) (defun org-export-table-cell-alignment (table-cell info) "Return TABLE-CELL contents alignment. @@ -4498,57 +4513,66 @@ alignment value will be deduced from fraction of numbers in the column (see `org-table-number-fraction' for more information). Possible values are `left', `right' and `center'." (let* ((row (org-export-get-parent table-cell)) + (table (org-export-get-parent row)) (column (let ((cells (org-element-contents row))) (- (length cells) (length (memq table-cell cells))))) - (table (org-export-get-parent-table table-cell)) - (number-cells 0) - (total-cells 0) - cookie-align - previous-cell-number-p) - (mapc - (lambda (row) - (cond - ;; In a special row, try to find an alignment cookie at - ;; COLUMN. - ((org-export-table-row-is-special-p row info) - (let ((value (org-element-contents - (elt (org-element-contents row) column)))) - ;; Since VALUE is a secondary string, the following checks - ;; avoid useless expansion through `org-export-data'. - (when (and value - (not (cdr value)) - (stringp (car value)) - (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" - (car value)) - (match-string 1 (car value))) - (setq cookie-align (match-string 1 (car value)))))) - ;; Ignore table rules. - ((eq (org-element-property :type row) 'rule)) - ;; In a standard row, check if cell's contents are expressing - ;; some kind of number. Increase NUMBER-CELLS accordingly. - ;; Though, don't bother if an alignment cookie has already - ;; defined cell's alignment. - ((not cookie-align) - (let ((value (org-export-data - (org-element-contents - (elt (org-element-contents row) column)) - info))) - (incf total-cells) - ;; Treat an empty cell as a number if it follows a number - (if (not (or (string-match org-table-number-regexp value) - (and (string= value "") previous-cell-number-p))) - (setq previous-cell-number-p nil) - (setq previous-cell-number-p t) - (incf number-cells)))))) - (org-element-contents table)) - ;; Return value. Alignment specified by cookies has precedence - ;; over alignment deduced from cells contents. - (cond ((equal cookie-align "l") 'left) - ((equal cookie-align "r") 'right) - ((equal cookie-align "c") 'center) - ((>= (/ (float number-cells) total-cells) org-table-number-fraction) - 'right) - (t 'left)))) + (cache (or (plist-get info :table-cell-alignment-cache) + (plist-get (setq info + (plist-put info :table-cell-alignment-cache + (make-hash-table :test 'equal))) + :table-cell-alignment-cache)))) + (or (gethash (cons table column) cache) + (let ((number-cells 0) + (total-cells 0) + cookie-align + previous-cell-number-p) + (dolist (row (org-element-contents (org-export-get-parent row))) + (cond + ;; In a special row, try to find an alignment cookie at + ;; COLUMN. + ((org-export-table-row-is-special-p row info) + (let ((value (org-element-contents + (elt (org-element-contents row) column)))) + ;; Since VALUE is a secondary string, the following + ;; checks avoid useless expansion through + ;; `org-export-data'. + (when (and value + (not (cdr value)) + (stringp (car value)) + (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" + (car value)) + (match-string 1 (car value))) + (setq cookie-align (match-string 1 (car value)))))) + ;; Ignore table rules. + ((eq (org-element-property :type row) 'rule)) + ;; In a standard row, check if cell's contents are + ;; expressing some kind of number. Increase NUMBER-CELLS + ;; accordingly. Though, don't bother if an alignment + ;; cookie has already defined cell's alignment. + ((not cookie-align) + (let ((value (org-export-data + (org-element-contents + (elt (org-element-contents row) column)) + info))) + (incf total-cells) + ;; Treat an empty cell as a number if it follows + ;; a number. + (if (not (or (string-match org-table-number-regexp value) + (and (string= value "") previous-cell-number-p))) + (setq previous-cell-number-p nil) + (setq previous-cell-number-p t) + (incf number-cells)))))) + ;; Return value. Alignment specified by cookies has + ;; precedence over alignment deduced from cell's contents. + (puthash (cons table column) + (cond ((equal cookie-align "l") 'left) + ((equal cookie-align "r") 'right) + ((equal cookie-align "c") 'center) + ((>= (/ (float number-cells) total-cells) + org-table-number-fraction) + 'right) + (t 'left)) + cache))))) (defun org-export-table-cell-borders (table-cell info) "Return TABLE-CELL borders. @@ -4739,20 +4763,14 @@ Address is a CONS cell (ROW . COLUMN), where ROW and COLUMN are zero-based index. Only exportable cells are considered. The function returns nil for other cells." (let* ((table-row (org-export-get-parent table-cell)) - (table (org-export-get-parent-table table-cell))) - ;; Ignore cells in special rows or in special column. - (unless (or (org-export-table-row-is-special-p table-row info) - (and (org-export-table-has-special-column-p table) - (eq (car (org-element-contents table-row)) table-cell))) - (cons - ;; Row number. - (org-export-table-row-number (org-export-get-parent table-cell) info) - ;; Column number. - (let ((col-count 0)) - (org-element-map table-row 'table-cell - (lambda (cell) - (if (eq cell table-cell) col-count (incf col-count) nil)) - info 'first-match)))))) + (row-number (org-export-table-row-number table-row info))) + (when row-number + (cons row-number + (let ((col-count 0)) + (org-element-map table-row 'table-cell + (lambda (cell) + (if (eq cell table-cell) col-count (incf col-count) nil)) + info 'first-match)))))) (defun org-export-get-table-cell-at (address table info) "Return regular table-cell object at ADDRESS in TABLE. @@ -5078,7 +5096,7 @@ Return the new string." ;; `org-export-get-genealogy' returns the full genealogy of a given ;; element or object, from closest parent to full parse tree. -(defun org-export-get-parent (blob) +(defsubst org-export-get-parent (blob) "Return BLOB parent or nil. BLOB is the element or object considered." (org-element-property :parent blob)) diff --git a/testing/lisp/test-ox.el b/testing/lisp/test-ox.el index 5e43df676..0f476a6b5 100644 --- a/testing/lisp/test-ox.el +++ b/testing/lisp/test-ox.el @@ -2015,36 +2015,41 @@ Another text. (ref:text) (ert-deftest test-org-export/table-row-group () "Test `org-export-table-row-group' specifications." ;; 1. A rule creates a new group. - (org-test-with-parsed-data " + (should + (equal '(1 rule 2) + (org-test-with-parsed-data " | a | b | |---+---| | 1 | 2 |" - (should - (equal - '(1 nil 2) - (mapcar (lambda (row) (org-export-table-row-group row info)) - (org-element-map tree 'table-row 'identity))))) + (org-element-map tree 'table-row + (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. - (org-test-with-parsed-data " + (should + (equal + '(rule 1) + (org-test-with-parsed-data " | / | < | > | |---|---+---| | | 1 | 2 |" - (should - (equal - '(nil nil 1) - (mapcar (lambda (row) (org-export-table-row-group row info)) - (org-element-map tree 'table-row 'identity))))) + (org-element-map tree 'table-row + (lambda (row) + (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. - (org-test-with-parsed-data " + (should + (equal '(1 rule rule 2) + (org-test-with-parsed-data " | a | b | |---+---| |---+---| | 1 | 2 |" - (should - (equal - '(1 nil nil 2) - (mapcar (lambda (row) (org-export-table-row-group row info)) - (org-element-map tree 'table-row 'identity)))))) + (org-element-map tree 'table-row + (lambda (row) + (if (eq (org-element-property :type row) 'rule) 'rule + (org-export-table-row-group row info)))))))) (ert-deftest test-org-export/table-row-number () "Test `org-export-table-row-number' specifications." -- 2.11.4.GIT