Browse Source

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>
Nicolas Goaziou 8 years ago
parent
commit
2f5cd67357
2 changed files with 78 additions and 72 deletions
  1. 66 60
      lisp/ox.el
  2. 12 12
      testing/lisp/test-ox.el

+ 66 - 60
lisp/ox.el

@@ -4747,19 +4747,20 @@ code."
 All special columns will be ignored during export."
 All special columns will be ignored during export."
   ;; The table has a special column when every first cell of every row
   ;; The table has a special column when every first cell of every row
   ;; has an empty value or contains a symbol among "/", "#", "!", "$",
   ;; 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
     (catch 'exit
       (dolist (row (org-element-contents table))
       (dolist (row (org-element-contents table))
 	(when (eq (org-element-property :type row) 'standard)
 	(when (eq (org-element-property :type row) 'standard)
 	  (let ((value (org-element-contents
 	  (let ((value (org-element-contents
 			(car (org-element-contents row)))))
 			(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))))))
 		  (t (throw 'exit nil))))))
-      (eq special-column-p 'special))))
+      (eq special-column? 'special))))
 
 
 (defun org-export-table-has-header-p (table info)
 (defun org-export-table-has-header-p (table info)
   "Non-nil when TABLE has a header.
   "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.
 INFO is a plist used as a communication channel.
 
 
 A table has a header when it contains at least two row groups."
 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 _)
 (defun org-export-table-row-is-special-p (table-row _)
   "Non-nil if TABLE-ROW is considered special.
   "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
 Return value is the group number, as an integer, or nil for
 special rows and rows separators.  First group is also table's
 special rows and rows separators.  First group is also table's
 header."
 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)
 (defun org-export-table-cell-width (table-cell info)
   "Return TABLE-CELL contents width.
   "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)
 (defun org-export-table-row-number (table-row info)
   "Return TABLE-ROW number.
   "Return TABLE-ROW number.
 INFO is a plist used as a communication channel.  Return value is
 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)
 (defun org-export-table-dimensions (table info)
   "Return TABLE dimensions.
   "Return TABLE dimensions.

+ 12 - 12
testing/lisp/test-ox.el

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