org-table: Fix table alignment

* lisp/org-table.el (org-table-align): Refactor function fix wrong
  alignment bug.
* lisp/org-compat.el (org-format-transports-properties-p): Remove
  variable.
* testing/lisp/test-org.el (test-org/fill-paragraph): Fix test

Reported-by: William Denton <wtd@pobox.com>
<http://permalink.gmane.org/gmane.emacs.orgmode/98901>

3 files changed, 161 insertions, 196 deletions

diff --git a/lisp/org-compat.el b/lisp/org-compat.el
index 64e0379..6bd3bfd 100644
--- a/lisp/org-compat.el
+++ b/lisp/org-compat.el
@@ -40,11 +40,6 @@
 ;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs)
 ;; at compilation time and can therefore optimize code better.
 (defconst org-xemacs-p (featurep 'xemacs))
-(defconst org-format-transports-properties-p
-  (let ((x "a"))
-    (add-text-properties 0 1 '(test t) x)
-    (get-text-property 0 'test (format "%s" x)))
-  "Does format transport text properties?")
 
 (defun org-compatible-face (inherits specs)
   "Make a compatible face specification.
diff --git a/lisp/org-table.el b/lisp/org-table.el
index 7adcf71..ada1ea4 100644
--- a/lisp/org-table.el
+++ b/lisp/org-table.el
@@ -725,198 +725,168 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
 (defun org-table-align ()
   "Align the table at point by aligning all vertical bars."
   (interactive)
-  (let* (
-	 ;; Limits of table
-	 (beg (org-table-begin))
-	 (end (copy-marker (org-table-end)))
-	 ;; Current cursor position
-	 (linepos (org-current-line))
-	 (colpos (org-table-current-column))
-	 (winstart (window-start))
-	 (winstartline (org-current-line (min winstart (1- (point-max)))))
-	 lines lengths l typenums ty fields maxfields i
-	 column
-	 (indent "") cnt frac
-	 rfmt hfmt
-	 (spaces '(1 . 1))
-	 (sp1 (car spaces))
-	 (sp2 (cdr spaces))
-	 (rfmt1 (concat
-		 (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|"))
-	 (hfmt1 (concat
-		 (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+"))
-	 emptystrings links dates emph raise narrow
-	 falign falign1 fmax f1 f2 len c e space)
-    (untabify beg end)
-    (remove-text-properties beg end '(org-cwidth t org-dwidth t display t))
-    ;; Check if we have links or dates
-    (goto-char beg)
-    (setq links (re-search-forward org-bracket-link-regexp end t))
-    (goto-char beg)
-    (setq emph (and org-hide-emphasis-markers
-		    (re-search-forward org-emph-re end t)))
-    (goto-char beg)
-    (setq raise (and org-use-sub-superscripts
-		     (re-search-forward org-match-substring-regexp end t)))
-    (goto-char beg)
-    (setq dates (and org-display-custom-times
-		     (re-search-forward org-ts-regexp-both end t)))
-    ;; Make sure the link properties are right
-    (when links (goto-char beg) (while (org-activate-bracket-links end)))
-    ;; Make sure the date properties are right
-    (when dates (goto-char beg) (while (org-activate-dates end)))
-    (when emph (goto-char beg) (while (org-do-emphasis-faces end)))
-    (when raise (goto-char beg) (while (org-raise-scripts end)))
-
-    ;; Check if we are narrowing any columns
+  (let ((beg (org-table-begin))
+	(end (copy-marker (org-table-end)))
+	(linepos (copy-marker (line-beginning-position)))
+	(colpos (org-table-current-column)))
+    ;; Make sure invisible characters in the table are at the right
+    ;; place since column widths take them into account.
+    (font-lock-fontify-region beg end)
+    (move-marker org-table-aligned-begin-marker beg)
+    (move-marker org-table-aligned-end-marker end)
     (goto-char beg)
-    (setq narrow (and org-table-do-narrow
-		      org-format-transports-properties-p
-		      (re-search-forward "<[lrc]?[0-9]+>" end t)))
-    (goto-char beg)
-    (setq falign (re-search-forward "<[lrc][0-9]*>" end t))
-    (goto-char beg)
-    ;; Get the rows
-    (setq lines (org-split-string
-		 (buffer-substring beg end) "\n"))
-    ;; Store the indentation of the first line
-    (if (string-match "^ *" (car lines))
-	(setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ )))
-    ;; Mark the hlines by setting the corresponding element to nil
-    ;; At the same time, we remove trailing space.
-    (setq lines (mapcar (lambda (l)
-			  (if (string-match "^ *|-" l)
-			      nil
-			    (if (string-match "[ \t]+$" l)
-				(substring l 0 (match-beginning 0))
-			      l)))
-			lines))
-    ;; Get the data fields by splitting the lines.
-    (setq fields (mapcar
-		  (lambda (l)
-		    (org-split-string l " *| *"))
-		  (delq nil (copy-sequence lines))))
-    ;; How many fields in the longest line?
-    (condition-case nil
-	(setq maxfields (apply 'max (mapcar 'length fields)))
-      (error
-       (kill-region beg end)
-       (org-table-create org-table-default-size)
-       (user-error "Empty table - created default table")))
-    ;; A list of empty strings to fill any short rows on output
-    (setq emptystrings (make-list maxfields ""))
-    ;; Check for special formatting.
-    (setq i -1)
-    (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns
-      (setq column (mapcar (lambda (x) (or (nth i x) "")) fields))
-      ;; Check if there is an explicit width specified
-      (setq fmax nil)
-      (when (or narrow falign)
-	(setq c column fmax nil falign1 nil)
-	(while c
-	  (setq e (pop c))
-	  (when (and (stringp e) (string-match "^<\\([lrc]\\)?\\([0-9]+\\)?>$" e))
-	    (if (match-end 1) (setq falign1 (match-string 1 e)))
-	    (if (and org-table-do-narrow (match-end 2))
-		(setq fmax (string-to-number (match-string 2 e)) c nil))))
-	;; Find fields that are wider than fmax, and shorten them
-	(when fmax
-	  (loop for xx in column do
-		(when (and (stringp xx)
-			   (> (org-string-width xx) fmax))
-		  (org-add-props xx nil
+    (let* ((indent (progn (looking-at "[ \t]*") (match-string 0)))
+	   ;; Table's rows.  Separators are replaced by nil.  Trailing
+	   ;; spaces are also removed.
+	   (lines (mapcar (lambda (l)
+			    (and (not (org-string-match-p "\\`[ \t]*|-" l))
+				 (let ((l (org-trim l)))
+				   (remove-text-properties
+				    0 (length l) '(display t org-cwidth t) l)
+				   l)))
+			  (org-split-string (buffer-substring beg end) "\n")))
+	   ;; Get the data fields by splitting the lines.
+	   (fields (mapcar (lambda (l) (org-split-string l " *| *"))
+			   (remq nil lines)))
+	   ;; Compute number of fields in the longest line.  If the
+	   ;; table contains no field, create a default table.
+	   (maxfields (if fields (apply #'max (mapcar #'length fields))
+			(kill-region beg end)
+			(org-table-create org-table-default-size)
+			(user-error "Empty table - created default table")))
+	   ;; A list of empty strings to fill any short rows on output.
+	   (emptycells (make-list maxfields ""))
+	   lengths typenums)
+      ;; Check for special formatting.
+      (dotimes (i maxfields)
+	(let ((column (mapcar (lambda (x) (or (nth i x) "")) fields))
+	      fmax falign)
+	  ;; Look for an explicit width or alignment.
+	  (when (save-excursion
+		  (or (re-search-forward "| *<[lrc][0-9]*> *\\(|\\|$\\)" end t)
+		      (and org-table-do-narrow
+			   (re-search-forward
+			    "| *<[lrc]?[0-9]+> *\\(|\\|$\\)" end t))))
+	    (catch :exit
+	      (dolist (cell column)
+		(when (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" cell)
+		  (when (match-end 1) (setq falign (match-string 1 cell)))
+		  (when (and org-table-do-narrow (match-end 2))
+		    (setq fmax (string-to-number (match-string 2 cell))))
+		  (when (or falign fmax) (throw :exit nil)))))
+	    ;; Find fields that are wider than FMAX, and shorten them.
+	    (when fmax
+	      (dolist (x column)
+		(when (> (org-string-width x) fmax)
+		  (org-add-props x nil
 		    'help-echo
-		    (concat "Clipped table field, use C-c ` to edit.  Full value is:\n"
-			    (org-no-properties (copy-sequence xx))))
-		  (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax)))
-		  (unless (> f1 1)
-		    (user-error "Cannot narrow field starting with wide link \"%s\""
-				(match-string 0 xx)))
-		  (setq f2 (length xx))
-		  (if (= (org-string-width xx)
-			 f2)
-		      (setq f2 f1)
-		    (setq f2 1)
-		    (while (< (org-string-width (substring xx 0 f2))
-			      f1)
-		      (setq f2 (1+ f2))))
-		  (add-text-properties f2 (length xx) (list 'org-cwidth t) xx)
-		  (add-text-properties (if (>= (string-width (substring xx (1- f2) f2)) 2)
-					   (1- f2) (- f2 2)) f2
-					   (list 'display org-narrow-column-arrow)
-					   xx)))))
-      ;; Get the maximum width for each column
-      (push (apply 'max (or fmax 1) 1 (mapcar 'org-string-width column))
-	    lengths)
-      ;; Get the fraction of numbers, to decide about alignment of the column
-      (if falign1
-	  (push (equal (downcase falign1) "r") typenums)
-	(setq cnt 0 frac 0.0)
-	(loop for x in column do
-	      (if (equal x "")
-		  nil
-		(setq frac ( / (+ (* frac cnt)
-				  (if (string-match org-table-number-regexp x) 1 0))
-			       (setq cnt (1+ cnt))))))
-	(push (>= frac org-table-number-fraction) typenums)))
-    (setq lengths (nreverse lengths) typenums (nreverse typenums))
-
-    ;; Store the alignment of this table, for later editing of single fields
-    (setq org-table-last-alignment typenums
-	  org-table-last-column-widths lengths)
-
-    ;; With invisible characters, `format' does not get the field width right
-    ;; So we need to make these fields wide by hand.
-    (when (or links emph raise)
-      (loop for i from 0 upto (1- maxfields) do
-	    (setq len (nth i lengths))
-	    (loop for j from 0 upto (1- (length fields)) do
-		  (setq c (nthcdr i (car (nthcdr j fields))))
-		  (if (and (stringp (car c))
-			   (or (text-property-any 0 (length (car c))
-						  'invisible 'org-link (car c))
-			       (text-property-any 0 (length (car c))
-						  'org-dwidth t (car c)))
-			   (< (org-string-width (car c)) len))
-		      (progn
-			(setq space (make-string (- len (org-string-width (car c))) ?\ ))
-			(setcar c (if (nth i typenums)
-				      (concat space (car c))
-				    (concat (car c) space))))))))
-
-    ;; Compute the formats needed for output of the table
-    (setq rfmt (concat indent "|") hfmt (concat indent "|"))
-    (while (setq l (pop lengths))
-      (setq ty (if (pop typenums) "" "-")) ; number types flushright
-      (setq rfmt (concat rfmt (format rfmt1 ty l))
-	    hfmt (concat hfmt (format hfmt1 (make-string l ?-)))))
-    (setq rfmt (concat rfmt "\n")
-	  hfmt (concat (substring hfmt 0 -1) "|\n"))
-
-    (move-marker org-table-aligned-begin-marker (point))
-    ;; Replace modified lines only.
-    (dolist (l lines)
-      (let ((line (if l (apply #'format rfmt (append (pop fields) emptystrings))
-		    hfmt)))
-	(if (equal (buffer-substring (point) (line-beginning-position 2)) line)
-	    (forward-line)
-	  (insert line)
-	  (delete-region (point) (line-beginning-position 2)))))
-    (move-marker end nil)
-    (move-marker org-table-aligned-end-marker (point))
-    (when (and orgtbl-mode (not (derived-mode-p 'org-mode)))
-      (goto-char org-table-aligned-begin-marker)
-      (while (org-hide-wide-columns org-table-aligned-end-marker)))
-    ;; Try to move to the old location
-    (org-goto-line winstartline)
-    (setq winstart (point-at-bol))
-    (org-goto-line linepos)
-    (when (eq (window-buffer (selected-window)) (current-buffer))
-      (set-window-start (selected-window) winstart 'noforce))
-    (org-table-goto-column colpos)
-    (and org-table-overlay-coordinates (org-table-overlay-coordinates))
-    (setq org-table-may-need-update nil)
-    ))
+		    (concat
+		     (substitute-command-keys
+		      "Clipped table field, use \\[org-table-edit-field] to \
+edit.  Full value is:\n")
+		     (substring-no-properties x)))
+		  (let ((l (length x))
+			(f1 (min fmax
+				 (or (string-match org-bracket-link-regexp x)
+				     fmax)))
+			(f2 1))
+		    (unless (> f1 1)
+		      (user-error
+		       "Cannot narrow field starting with wide link \"%s\""
+		       (match-string 0 x)))
+		    (if (= (org-string-width x) l) (setq f2 f1)
+		      (setq f2 1)
+		      (while (< (org-string-width (substring x 0 f2)) f1)
+			(incf f2)))
+		    (add-text-properties f2 l (list 'org-cwidth t) x)
+		    (add-text-properties
+		     (if (>= (string-width (substring x (1- f2) f2)) 2) (1- f2)
+		       (- f2 2))
+		     f2
+		     (list 'display org-narrow-column-arrow)
+		     x))))))
+	  ;; Get the maximum width for each column
+	  (push (apply #'max (or fmax 1) 1 (mapcar #'org-string-width column))
+		lengths)
+	  ;; Get the fraction of numbers among non-empty cells to
+	  ;; decide about alignment of the column.
+	  (if falign (push (equal (downcase falign) "r") typenums)
+	    (let ((cnt 0)
+		  (frac 0.0))
+	      (dolist (x column)
+		(unless (equal x "")
+		  (setq frac
+			(/ (+ (* frac cnt)
+			      (if (org-string-match-p org-table-number-regexp x)
+				  1
+				0))
+			   (incf cnt)))))
+	      (push (>= frac org-table-number-fraction) typenums)))))
+      (setq lengths (nreverse lengths))
+      (setq typenums (nreverse typenums))
+      ;; Store alignment of this table, for later editing of single
+      ;; fields.
+      (setq org-table-last-alignment typenums)
+      (setq org-table-last-column-widths lengths)
+      ;; With invisible characters, `format' does not get the field
+      ;; width right So we need to make these fields wide by hand.
+      ;; Invisible characters may be introduced by fontified links,
+      ;; emphasis, macros or sub/superscripts.
+      (when (or (text-property-any beg end 'invisible 'org-link)
+		(text-property-any beg end 'invisible t))
+	(dotimes (i maxfields)
+	  (let ((len (nth i lengths)))
+	    (dotimes (j (length fields))
+	      (let* ((c (nthcdr i (nth j fields)))
+		     (cell (car c)))
+		(when (and
+		       (stringp cell)
+		       (let ((l (length cell)))
+			 (or (text-property-any 0 l 'invisible 'org-link cell)
+			     (text-property-any beg end 'invisible t)))
+		       (< (org-string-width cell) len))
+		  (let ((s (make-string (- len (org-string-width cell)) ?\s)))
+		    (setcar c (if (nth i typenums) (concat s cell)
+				(concat cell s))))))))))
+
+      ;; Compute the formats needed for output of the table.
+      (let ((hfmt (concat indent "|"))
+	    (rfmt (concat indent "|"))
+	    (rfmt1 " %%%s%ds |")
+	    (hfmt1 "-%s-+"))
+	(dolist (l lengths (setq hfmt (concat (substring hfmt 0 -1) "|")))
+	  (let ((ty (if (pop typenums) "" "-"))) ; Flush numbers right.
+	    (setq rfmt (concat rfmt (format rfmt1 ty l)))
+	    (setq hfmt (concat hfmt (format hfmt1 (make-string l ?-))))))
+	;; Replace modified lines only.  Check not only contents, but
+	;; also columns' width.
+	(dolist (l lines)
+	  (let ((line
+		 (if l (apply #'format rfmt (append (pop fields) emptycells))
+		   hfmt))
+		(previous (buffer-substring (point) (line-end-position))))
+	    (if (and (equal previous line)
+		     (let ((a 0)
+			   (b 0))
+		       (while (and (progn
+				     (setq a (next-single-property-change
+					      a 'org-cwidth previous))
+				     (setq b (next-single-property-change
+					      b 'org-cwidth line)))
+				   (eq a b)))
+		       (eq a b)))
+		(forward-line)
+	      (insert line "\n")
+	      (delete-region (point) (line-beginning-position 2))))))
+      (when (and orgtbl-mode (not (derived-mode-p 'org-mode)))
+	(goto-char org-table-aligned-begin-marker)
+	(while (org-hide-wide-columns org-table-aligned-end-marker)))
+      (goto-char linepos)
+      (org-table-goto-column colpos)
+      (set-marker end nil)
+      (set-marker linepos nil)
+      (when org-table-overlay-coordinates (org-table-overlay-coordinates))
+      (setq org-table-may-need-update nil))))
 
 ;;;###autoload
 (defun org-table-begin (&optional table-type)
diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el
index bd486d1..af9dbff 100644
--- a/testing/lisp/test-org.el
+++ b/testing/lisp/test-org.el
@@ -352,7 +352,7 @@
 	    (buffer-string))))
   (should
    (equal "#+name: table\n| a |\n"
-	  (org-test-with-temp-text "#+name: table\n| a |"
+	  (org-test-with-temp-text "#+name: table\n| a |\n"
 	    (org-fill-paragraph)
 	    (buffer-string))))
   ;; At a paragraph, preserve line breaks.