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

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>
This commit is contained in:
Nicolas Goaziou 2015-07-09 17:53:33 +02:00
parent 22c652599c
commit 120dcd1d13
3 changed files with 160 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lisp/org-compat.el
View File

@ -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.

348
lisp/org-table.el
View File

@ -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
(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 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
(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))
(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))))))))))
;; 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)
))
;; 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)

2
testing/lisp/test-org.el
View File

@ -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.