summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicolas Goaziou <mail@nicolasgoaziou.fr>2017-06-27 23:06:02 +0200
committerNicolas Goaziou <mail@nicolasgoaziou.fr>2017-09-06 15:18:37 +0200
commit6d6a30d4cd682732ba40328bbeb96122a50f96ff (patch)
tree4c92cbda4ac1a710ab35dc3c3d57cb438d914eca
parent331ba684956faa9732365db209ac6c6822735932 (diff)
downloadorg-mode-6d6a30d4cd682732ba40328bbeb96122a50f96ff.tar.gz
org-table: Implement shrunk columns
* lisp/org-table.el (org-table-shrunk-column-indicator): New variable. (org-table-with-shrunk-columns): New macro. (org-table--shrunk-field): (org-table--list-shrunk-columns): (org-table--shrink-field): (org-table--read-column-selection): (org-table--expand-all-columns): (org-table-toggle-column-width): New functions. (org-table-align): (org-table-get-field): (org-table-insert-column): (org-table-delete-column): (org-table-move-column): (org-table-move-row): (org-table-insert-row): (org-table-insert-hline): (org-table-kill-row): (org-table-sort-lines): Use new functions. (org-table-overlay-coordinates): (org-table-toggle-coordinate-overlays): Tiny refactoring. * testing/lisp/test-org-table.el (test-org-table/toggle-column-width): (test-org-table/shrunk-columns): New tests.
-rw-r--r--lisp/org-table.el867
-rw-r--r--lisp/org.el4
-rw-r--r--testing/lisp/test-org-table.el218
3 files changed, 819 insertions, 270 deletions
diff --git a/lisp/org-table.el b/lisp/org-table.el
index 90401e5..c14ff01 100644
--- a/lisp/org-table.el
+++ b/lisp/org-table.el
@@ -422,6 +422,14 @@ prevents it from hanging emacs."
:version "26.1"
:package-version '(Org . "8.3"))
+(defcustom org-table-shrunk-column-indicator "…"
+ "String to be displayed in a shrunk column."
+ :group 'org-table-editing
+ :type 'string
+ :version "26.1"
+ :package-version '(Org . "9.1")
+ :safe (lambda (v) (and (stringp v) (not (equal v "")))))
+
(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)"
"Regexp matching a line marked for automatic recalculation.")
@@ -509,6 +517,20 @@ Field is restored even in case of abnormal exit."
(org-table-goto-column ,column)
(set-marker ,line nil)))))
+(defmacro org-table-with-shrunk-columns (&rest body)
+ "Expand all columns before executing BODY, then shrink them again."
+ (declare (debug (body)))
+ (org-with-gensyms (shrunk-columns begin end)
+ `(let ((,begin (copy-marker (org-table-begin)))
+ (,end (copy-marker (org-table-end) t))
+ (,shrunk-columns (org-table--list-shrunk-columns)))
+ (org-with-point-at ,begin (org-table--expand-all-columns ,begin ,end))
+ (unwind-protect
+ (progn ,@body)
+ (org-table--shrink-columns ,shrunk-columns ,begin ,end)
+ (set-marker ,begin nil)
+ (set-marker ,end nil)))))
+
;;;###autoload
(defun org-table-create-with-table.el ()
"Use the table.el package to insert a new table.
@@ -757,8 +779,8 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(defun org-table-align ()
"Align the table at point by aligning all vertical bars."
(interactive)
- (let* ((beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let ((beg (org-table-begin))
+ (end (copy-marker (org-table-end))))
(org-table-save-field
;; Make sure invisible characters in the table are at the right
;; place since column widths take them into account.
@@ -766,154 +788,155 @@ When nil, simply write \"#ERROR\" in corrupted fields.")
(move-marker org-table-aligned-begin-marker beg)
(move-marker org-table-aligned-end-marker end)
(goto-char beg)
- (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 (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 (> (string-width x) fmax)
- (org-add-props x nil
- 'help-echo
- (concat
- "Clipped table field, use `\\[org-table-edit-field]' to \
+ (org-table-with-shrunk-columns
+ (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 (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 `\\[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)
- (cl-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 (or fmax (apply #'max 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 (string-match-p org-table-number-regexp x)
- 1
- 0))
- (cl-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)))
- (set-marker end nil)
- (when org-table-overlay-coordinates (org-table-overlay-coordinates))
- (setq org-table-may-need-update nil)))))
+ (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)
+ (cl-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 (string-match-p org-table-number-regexp x)
+ 1
+ 0))
+ (cl-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)))
+ (set-marker end 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)
@@ -1277,7 +1300,16 @@ value."
(let* ((pos (match-beginning 0))
(val (buffer-substring pos (match-end 0))))
(when replace
- (replace-match (if (equal replace "") " " replace) t t))
+ ;; Since we are going to remove any hidden field, do not rely
+ ;; on `org-table--hidden-field' as it could be GC'ed before
+ ;; second check.
+ (let* ((hide-overlay (org-table--shrunk-field))
+ (begin (and hide-overlay (overlay-start hide-overlay))))
+ (when hide-overlay (delete-overlay hide-overlay))
+ (replace-match (if (equal replace "") " " replace) t t)
+ (when hide-overlay
+ (move-overlay hide-overlay
+ begin (+ begin (min 1 (length replace)))))))
(goto-char (min (line-end-position) (1+ pos)))
val)))
@@ -1379,9 +1411,11 @@ However, when FORCE is non-nil, create new columns if necessary."
(interactive)
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
- (let* ((col (max 1 (org-table-current-column)))
- (beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let ((col (max 1 (org-table-current-column)))
+ (beg (org-table-begin))
+ (end (copy-marker (org-table-end)))
+ (shrunk-columns (org-table--list-shrunk-columns)))
+ (org-table--expand-all-columns beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
@@ -1389,8 +1423,14 @@ However, when FORCE is non-nil, create new columns if necessary."
(org-table-goto-column col t)
(insert "| "))
(forward-line)))
- (set-marker end nil)
(org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then hide the
+ ;; columns again.
+ (org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1+ c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas "$" nil (1- col) 1)
@@ -1445,9 +1485,11 @@ non-nil, the one above is used."
(unless (org-at-table-p) (user-error "Not at a table"))
(org-table-find-dataline)
(org-table-check-inside-data-field)
- (let ((col (org-table-current-column))
- (beg (org-table-begin))
- (end (copy-marker (org-table-end))))
+ (let* ((col (org-table-current-column))
+ (beg (org-table-begin))
+ (end (copy-marker (org-table-end)))
+ (shrunk-columns (remq col (org-table--list-shrunk-columns))))
+ (org-table--expand-all-columns beg end)
(org-table-save-field
(goto-char beg)
(while (< (point) end)
@@ -1457,9 +1499,15 @@ non-nil, the one above is used."
(and (looking-at "|[^|\n]+|")
(replace-match "|")))
(forward-line)))
- (set-marker end nil)
(org-table-goto-column (max 1 (1- col)))
(org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then hide the
+ ;; columns again.
+ (org-table--shrink-columns (mapcar (lambda (c) (if (< c col) c (1- c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
(when (or (not org-table-fix-formulas-confirm)
(funcall org-table-fix-formulas-confirm "Fix formulas? "))
(org-table-fix-formulas
@@ -1472,6 +1520,7 @@ non-nil, the one above is used."
"Move column to the right."
(interactive)
(org-table-move-column nil))
+
;;;###autoload
(defun org-table-move-column-left ()
"Move column to the left."
@@ -1494,33 +1543,49 @@ non-nil, the one above is used."
(user-error "Cannot move column further left"))
(when (and (not left) (looking-at "[^|\n]*|[^|\n]*$"))
(user-error "Cannot move column further right"))
- (org-table-save-field
- (goto-char beg)
- (while (< (point) end)
- (unless (org-at-table-hline-p)
- (org-table-goto-column col1 t)
- (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|")
- (transpose-regions
- (match-beginning 1) (match-end 1)
- (match-beginning 2) (match-end 2))))
- (forward-line)))
- (set-marker end nil)
- (org-table-goto-column colpos)
- (org-table-align)
- (when (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm "Fix formulas? "))
- (org-table-fix-formulas
- "$" (list (cons (number-to-string col) (number-to-string colpos))
- (cons (number-to-string colpos) (number-to-string col))))
- (org-table-fix-formulas
- "$LR" (list (cons (number-to-string col) (number-to-string colpos))
- (cons (number-to-string colpos) (number-to-string col)))))))
+ (let ((shrunk-columns (org-table--list-shrunk-columns)))
+ (org-table--expand-all-columns beg end)
+ (org-table-save-field
+ (goto-char beg)
+ (while (< (point) end)
+ (unless (org-at-table-hline-p)
+ (org-table-goto-column col1 t)
+ (when (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|")
+ (transpose-regions
+ (match-beginning 1) (match-end 1)
+ (match-beginning 2) (match-end 2))))
+ (forward-line)))
+ (org-table-goto-column colpos)
+ (org-table-align)
+ ;; Shift appropriately stored shrunk column numbers, then shrink
+ ;; the columns again.
+ (org-table--shrink-columns
+ (mapcar (lambda (c)
+ (cond ((and (= col c) left) (1- c))
+ ((= col c) (1+ c))
+ ((and (= col (1+ c)) left) (1+ c))
+ ((and (= col (1- c)) (not left) (1- c)))
+ (t c)))
+ shrunk-columns)
+ beg end)
+ (set-marker end nil)
+ ;; Fix TBLFM formulas, if desirable.
+ (when (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm "Fix formulas? "))
+ (org-table-fix-formulas
+ "$" (list (cons (number-to-string col) (number-to-string colpos))
+ (cons (number-to-string colpos) (number-to-string col))))
+ (org-table-fix-formulas
+ "$LR" (list
+ (cons (number-to-string col) (number-to-string colpos))
+ (cons (number-to-string colpos) (number-to-string col))))))))
;;;###autoload
(defun org-table-move-row-down ()
"Move table row down."
(interactive)
(org-table-move-row nil))
+
;;;###autoload
(defun org-table-move-row-up ()
"Move table row up."
@@ -1545,24 +1610,25 @@ non-nil, the one above is used."
(when (or (and (not up) (eobp)) (not (org-at-table-p)))
(goto-char pos)
(user-error "Cannot move row further"))
- (setq hline2p (looking-at org-table-hline-regexp))
- (goto-char pos)
- (let ((row (delete-and-extract-region (line-beginning-position)
- (line-beginning-position 2))))
- (beginning-of-line tonew)
- (unless (bolp) (insert "\n")) ;at eob without a newline
- (insert row)
- (unless (bolp) (insert "\n")) ;missing final newline in ROW
- (beginning-of-line 0)
- (org-move-to-column col)
- (unless (or hline1p hline2p
- (not (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm
- "Fix formulas? "))))
- (org-table-fix-formulas
- "@" (list
- (cons (number-to-string dline1) (number-to-string dline2))
- (cons (number-to-string dline2) (number-to-string dline1))))))))
+ (org-table-with-shrunk-columns
+ (setq hline2p (looking-at org-table-hline-regexp))
+ (goto-char pos)
+ (let ((row (delete-and-extract-region (line-beginning-position)
+ (line-beginning-position 2))))
+ (beginning-of-line tonew)
+ (unless (bolp) (insert "\n")) ;at eob without a newline
+ (insert row)
+ (unless (bolp) (insert "\n")) ;missing final newline in ROW
+ (beginning-of-line 0)
+ (org-move-to-column col)
+ (unless (or hline1p hline2p
+ (not (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm
+ "Fix formulas? "))))
+ (org-table-fix-formulas
+ "@" (list
+ (cons (number-to-string dline1) (number-to-string dline2))
+ (cons (number-to-string dline2) (number-to-string dline1)))))))))
;;;###autoload
(defun org-table-insert-row (&optional arg)
@@ -1570,47 +1636,48 @@ non-nil, the one above is used."
With prefix ARG, insert below the current line."
(interactive "P")
(unless (org-at-table-p) (user-error "Not at a table"))
- (let* ((line (buffer-substring (line-beginning-position) (line-end-position)))
- (new (org-table-clean-line line)))
- ;; Fix the first field if necessary
- (if (string-match "^[ \t]*| *[#$] *|" line)
- (setq new (replace-match (match-string 0 line) t t new)))
- (beginning-of-line (if arg 2 1))
- ;; Buffer may not end of a newline character, so ensure
- ;; (beginning-of-line 2) moves point to a new line.
- (unless (bolp) (insert "\n"))
- (let (org-table-may-need-update) (insert-before-markers new "\n"))
- (beginning-of-line 0)
- (re-search-forward "| ?" (line-end-position) t)
- (when (or org-table-may-need-update org-table-overlay-coordinates)
- (org-table-align))
- (when (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm "Fix formulas? "))
- (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))))
+ (org-table-with-shrunk-columns
+ (let* ((line (buffer-substring (line-beginning-position) (line-end-position)))
+ (new (org-table-clean-line line)))
+ ;; Fix the first field if necessary
+ (when (string-match "^[ \t]*| *[#$] *|" line)
+ (setq new (replace-match (match-string 0 line) t t new)))
+ (beginning-of-line (if arg 2 1))
+ ;; Buffer may not end of a newline character, so ensure
+ ;; (beginning-of-line 2) moves point to a new line.
+ (unless (bolp) (insert "\n"))
+ (let (org-table-may-need-update) (insert-before-markers new "\n"))
+ (beginning-of-line 0)
+ (re-search-forward "| ?" (line-end-position) t)
+ (when (or org-table-may-need-update org-table-overlay-coordinates)
+ (org-table-align))
+ (when (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm "Fix formulas? "))
+ (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1)))))
;;;###autoload
(defun org-table-insert-hline (&optional above)
"Insert a horizontal-line below the current line into the table.
With prefix ABOVE, insert above the current line."
(interactive "P")
- (if (not (org-at-table-p))
- (user-error "Not at a table"))
- (when (eobp) (insert "\n") (backward-char 1))
- (if (not (string-match-p "|[ \t]*$" (org-current-line-string)))
- (org-table-align))
- (let ((line (org-table-clean-line
- (buffer-substring (point-at-bol) (point-at-eol))))
- (col (current-column)))
- (while (string-match "|\\( +\\)|" line)
- (setq line (replace-match
- (concat "+" (make-string (- (match-end 1) (match-beginning 1))
- ?-) "|") t t line)))
- (and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
- (beginning-of-line (if above 1 2))
- (insert line "\n")
- (beginning-of-line (if above 1 -1))
- (org-move-to-column col)
- (and org-table-overlay-coordinates (org-table-align))))
+ (unless (org-at-table-p) (user-error "Not at a table"))
+ (when (eobp) (save-excursion (insert "\n")))
+ (unless (string-match-p "|[ \t]*$" (org-current-line-string))
+ (org-table-align))
+ (org-table-with-shrunk-columns
+ (let ((line (org-table-clean-line
+ (buffer-substring (point-at-bol) (point-at-eol))))
+ (col (current-column)))
+ (while (string-match "|\\( +\\)|" line)
+ (setq line (replace-match
+ (concat "+" (make-string (- (match-end 1) (match-beginning 1))
+ ?-) "|") t t line)))
+ (and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
+ (beginning-of-line (if above 1 2))
+ (insert line "\n")
+ (beginning-of-line (if above 1 -1))
+ (org-move-to-column col)
+ (when org-table-overlay-coordinates (org-table-align)))))
;;;###autoload
(defun org-table-hline-and-move (&optional same-column)
@@ -1643,17 +1710,17 @@ In particular, this does handle wide and invisible characters."
(defun org-table-kill-row ()
"Delete the current row or horizontal line from the table."
(interactive)
- (if (not (org-at-table-p))
- (user-error "Not at a table"))
+ (unless (org-at-table-p) (user-error "Not at a table"))
(let ((col (current-column))
(dline (org-table-current-dline)))
- (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))
- (if (not (org-at-table-p)) (beginning-of-line 0))
- (org-move-to-column col)
- (when (or (not org-table-fix-formulas-confirm)
- (funcall org-table-fix-formulas-confirm "Fix formulas? "))
- (org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID"))
- dline -1 dline))))
+ (org-table-with-shrunk-columns
+ (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max)))
+ (if (not (org-at-table-p)) (beginning-of-line 0))
+ (org-move-to-column col)
+ (when (or (not org-table-fix-formulas-confirm)
+ (funcall org-table-fix-formulas-confirm "Fix formulas? "))
+ (org-table-fix-formulas
+ "@" (list (cons (number-to-string dline) "INVALID")) dline -1 dline)))))
;;;###autoload
(defun org-table-sort-lines
@@ -1703,7 +1770,9 @@ function is being called interactively."
(sorting-type
(or sorting-type
(read-char-exclusive "Sort Table: [a]lphabetic, [n]umeric, \
-\[t]ime, [f]unc. A/N/T/F means reversed: "))))
+\[t]ime, [f]unc. A/N/T/F means reversed: ")))
+ (start (org-table-begin))
+ (end (org-table-end)))
(save-restriction
;; Narrow buffer to appropriate sorting area.
(if (org-region-active-p)
@@ -1712,16 +1781,14 @@ function is being called interactively."
(point)
(save-excursion (goto-char (region-end))
(line-beginning-position 2))))
- (let ((start (org-table-begin))
- (end (org-table-end)))
- (narrow-to-region
- (save-excursion
- (if (re-search-backward org-table-hline-regexp start t)
- (line-beginning-position 2)
- start))
- (if (save-excursion (re-search-forward org-table-hline-regexp end t))
- (match-beginning 0)
- end))))
+ (narrow-to-region
+ (save-excursion
+ (if (re-search-backward org-table-hline-regexp start t)
+ (line-beginning-position 2)
+ start))
+ (if (save-excursion (re-search-forward org-table-hline-regexp end t))
+ (match-beginning 0)
+ end)))
;; Determine arguments for `sort-subr'. Also record original
;; position. `org-table-save-field' cannot help here since
;; sorting is too much destructive.
@@ -1758,9 +1825,10 @@ function is being called interactively."
(or compare-func
(and interactive?
(org-read-function
- (concat "Function for comparing keys "
- "(empty for default `sort-subr' predicate): ")
- 'allow-empty)))))))
+ "Function for comparing keys (empty for default \
+`sort-subr' predicate): "
+ 'allow-empty))))))
+ (shrunk-columns (remq column (org-table--list-shrunk-columns))))
(goto-char (point-min))
(sort-subr (memq sorting-type '(?A ?N ?T ?F))
(lambda ()
@@ -1774,6 +1842,8 @@ function is being called interactively."
(org-trim (org-table-get-field column))))
nil
predicate)
+ ;; Hide all columns but the one being sorted.
+ (org-table--shrink-columns shrunk-columns start end)
;; Move back to initial field.
(forward-line (car coordinates))
(move-to-column (cdr coordinates))))))
@@ -3788,6 +3858,265 @@ minutes or seconds."
secs0)))))
(if (< secs 0) (concat "-" res) res)))
+
+
+;;; Columns shrinking
+
+(defun org-table--shrunk-field ()
+ "Non-nil if current field is narrowed.
+When non-nil, return the overlay narrowing the field."
+ (cl-some (lambda (o)
+ (and (eq 'table-column-hide (overlay-get o 'org-overlay-type))
+ o))
+ (overlays-in (1- (point)) (1+ (point)))))
+
+(defun org-table--list-shrunk-columns ()
+ "List currently shrunk columns in table at point."
+ (save-excursion
+ ;; We really check shrunk columns in current row only. It could
+ ;; be wrong if all rows do not contain the same number of columns
+ ;; (i.e. the table is not properly aligned). As a consequence,
+ ;; some columns may not be shrunk again upon aligning the table.
+ ;;
+ ;; For example, in the following table, cursor is on first row and
+ ;; "<>" indicates a shrunk column.
+ ;;
+ ;; | |
+ ;; | | <> |
+ ;;
+ ;; Aligning table from the first row will not shrink again the
+ ;; second row, which was not visible initially.
+ ;;
+ ;; However, fixing it requires to check every row, which may be
+ ;; slow on large tables. Moreover, the hindrance of this
+ ;; pathological case is very limited.
+ (beginning-of-line)
+ (search-forward "|")
+ (let ((separator (if (org-at-table-hline-p) "+" "|"))
+ (column 1)
+ (shrunk (and (org-table--shrunk-field) (list 1)))
+ (end (line-end-position)))
+ (while (search-forward separator end t)
+ (cl-incf column)
+ (when (org-table--shrunk-field) (push column shrunk)))
+ (nreverse shrunk))))
+
+(defun org-table--shrink-field (width start end contents)
+ "Shrink a table field to a specified width.
+
+WIDTH is an integer representing the number of characters to
+display, in addition to `org-table-shrunk-column-indicator'. START
+and END are, respectively, the beginning and ending positions of
+the field. CONTENTS is its trimmed contents, as a string, or
+`hline' for table rules.
+
+Real field is hidden under an overlay. The latter has the
+following properties:
+
+ `org-overlay-type'
+
+ Set to `table-column-hide'. Used to identify overlays
+ responsible for the task.
+
+ `org-table-column-overlays'
+
+ It is a list with the pattern (siblings . COLUMN-OVERLAYS)
+ where COLUMN-OVERLAYS is the list of all overlays hiding the
+ same column.
+
+Whenever the text behind or next to the overlay is modified, all
+the overlays in the column are deleted, effectively displaying
+the column again.
+
+Return overlay used to hide the field."
+ (unless (org-table--shrunk-field)
+ (let ((display
+ (cond
+ ((= width 0) org-table-shrunk-column-indicator)
+ ((eq contents 'hline)
+ (concat (make-string (1+ width) ?-)
+ org-table-shrunk-column-indicator))
+ (t
+ ;; Remove invisible parts from links in CONTENTS. Since
+ ;; shrinking could happen before first fontification
+ ;; (e.g., using a #+STARTUP keyword), this cannot be done
+ ;; using text properties.
+ (let* ((contents (org-string-display contents))
+ (field-width (string-width contents)))
+ (if (>= width field-width)
+ ;; Expand field.
+ (format " %s%s%s"
+ contents
+ (make-string (- width field-width) ?\s)
+ org-table-shrunk-column-indicator)
+ ;; Truncate field.
+ (format " %s%s"
+ (substring contents 0 width)
+ org-table-shrunk-column-indicator))))))
+ (show-before-edit
+ (list (lambda (o &rest _)
+ ;; Removing one overlay removes all other overlays
+ ;; in the same column.
+ (mapc #'delete-overlay
+ (cdr (overlay-get o 'org-table-column-overlays))))))
+ (o (make-overlay start end)))
+ (overlay-put o 'insert-behind-hooks show-before-edit)
+ (overlay-put o 'insert-in-front-hooks show-before-edit)
+ (overlay-put o 'modification-hooks show-before-edit)
+ (overlay-put o 'org-overlay-type 'table-column-hide)
+ (when (stringp contents) (overlay-put o 'help-echo contents))
+ ;; Make sure overlays stays on top of table coordinates
+ ;; overlays. See `org-table-overlay-coordinates'.
+ (overlay-put o 'priority 1)
+ (org-overlay-display o display 'org-table t)
+ o)))
+
+(defun org-table--read-column-selection (select max)
+ "Read column selection select as a list of numbers.
+
+SELECT is a string containing column ranges, separated by white
+space characters, see `org-table-hide-column' for details. MAX
+is the maximum column number.
+
+Return value is a sorted list of numbers. Ignore any number
+outside of the [1;MAX] range."
+ (catch :all
+ (sort
+ (delete-dups
+ (cl-mapcan
+ (lambda (s)
+ (cond
+ ((member s '("-" "1-")) (throw :all (number-sequence 1 max)))
+ ((string-match-p "\\`[0-9]+\\'" s)
+ (let ((n (string-to-number s)))
+ (and (> n 0) (<= n max) (list n))))
+ ((string-match "\\`\\([0-9]+\\)?-\\([0-9]+\\)?\\'" s)
+ (let ((n (match-string 1 s))
+ (m (match-string 2 s)))
+ (number-sequence (if n (max 1 (string-to-number n))
+ 1)
+ (if m (min max (string-to-number m))
+ max))))
+ (t nil))) ;invalid specification
+ (split-string select)))
+ #'<)))
+
+(defun org-table--shrink-columns (columns beg end)
+ "Shrink COLUMNS in an Org table.
+COLUMNS is a sorted list of column numbers. BEG and END are,
+respectively, the beginning position and the end position of the
+table."
+ (org-with-wide-buffer
+ (font-lock-ensure beg end)
+ (dolist (c columns)
+ (goto-char beg)
+ (let ((width nil)
+ (fields nil))
+ (while (< (point) end)
+ (catch :continue
+ (let* ((hline? (org-at-table-hline-p))
+ (separator (if hline? "+" "|")))
+ ;; Move to COLUMN.
+ (search-forward "|")
+ (or (= c 1) ;already there
+ (search-forward separator (line-end-position) t (1- c))
+ (throw :continue nil)) ;skip invalid columns
+ ;; Extract boundaries and contents from current field.
+ ;; Also set the column's width if we encounter a width
+ ;; cookie for the first time.
+ (let* ((start (point))
+ (end (progn
+ (skip-chars-forward (concat "^|" separator)
+ (line-end-position))
+ (point)))
+ (contents (if hline? 'hline
+ (org-trim (buffer-substring start end)))))
+ (push (list start end contents) fields)
+ (when (and (null width)
+ (not hline?)
+ (string-match "\\`<[lrc]?\\([0-9]+\\)>\\'" contents))
+ (setq width (string-to-number (match-string 1 contents)))))))
+ (forward-line))
+ ;; Link overlay to the other overlays in the same column.
+ (let ((chain (list 'siblings)))
+ (dolist (field fields)
+ (let ((new (apply #'org-table--shrink-field (or width 0) field)))
+ (push new (cdr chain))
+ (overlay-put new 'org-table-column-overlays chain))))))))
+
+(defun org-table--expand-all-columns (beg end)
+ "Expand all columns in an Org table.
+BEG and END are, respectively, the beginning position and the end
+position of the table."
+ (remove-overlays beg end 'org-overlay-type 'table-column-hide))
+
+;;;###autoload
+(defun org-table-toggle-column-width (&optional arg)
+ "Shrink or expand current column in an Org table.
+
+If a width cookie specifies a width W for the column, the first
+W visible characters are displayed. Otherwise, the column is
+shrunk to a single character.
+
+When optional argument ARG is a string, use it as white space
+separated list of column ranges. A column range can be one of
+the following patterns:
+
+ N column N only
+ N-M every column between N and M (both inclusive)
+ N- every column between N (inclusive) and the last column
+ -M every column between the first one and M (inclusive)
+ - every column
+
+When called with `\\[universal-argument]' prefix, ask for the \
+range specification.
+
+When called with `\\[universal-argument] \\[universal-argument]' \
+prefix, expand all columns."
+ (interactive "P")
+ (cond ((not (org-at-table-p)) (user-error "Not in a table"))
+ ((and (not arg)
+ (save-excursion
+ (skip-chars-backward "^|" (line-beginning-position))
+ (or (bolp) (looking-at-p "[ \t]*$"))))
+ ;; Point is either before first column or past last one.
+ (user-error "Not in a valid column")))
+ (let* ((pos (point))
+ (begin (org-table-begin))
+ (end (org-table-end))
+ ;; Compute an upper bound for the number of columns.
+ ;; Nonexistent columns are ignored anyway.
+ (max-columns (/ (- (line-end-position) (line-beginning-position)) 2))
+ (shrunk (org-table--list-shrunk-columns))
+ (columns (pcase arg
+ (`nil
+ ;; Find current column, even when on a hline.
+ (let ((separator (if (org-at-table-hline-p) "+" "|"))
+ (c 1))
+ (save-excursion
+ (beginning-of-line)
+ (search-forward "|" pos t)
+ (while (search-forward separator pos t) (cl-incf c)))
+ (list c)))
+ ((pred stringp)
+ (org-table--read-column-selection arg max-columns))
+ (`(4)
+ (org-table--read-column-selection
+ (read-string "Column ranges (e.g. 2-4 6-): ")
+ max-columns))
+ (`(16) nil)
+ (_ (user-error "Invalid argument: %S" arg)))))
+ (org-table--expand-all-columns begin end)
+ (unless (equal arg '(16))
+ (org-table--shrink-columns (cl-set-exclusive-or columns shrunk) begin end)
+ ;; Move before overlay if point is under it.
+ (let ((o (org-table--shrunk-field)))
+ (when o (goto-char (overlay-start o)))))))
+
+
+
+;;; Formula editing
+
(defun org-table-fedit-convert-buffer (function)
"Convert all references in this buffer, using FUNCTION."
(let ((origin (copy-marker (line-beginning-position))))
@@ -4218,7 +4547,7 @@ FACE, when non-nil, for the highlight."
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)
(save-excursion
- (let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg)
+ (let ((id 0) (ih 0) hline eol str ov)
(goto-char (org-table-begin))
(while (org-at-table-p)
(setq eol (point-at-eol))
@@ -4229,17 +4558,17 @@ FACE, when non-nil, for the highlight."
(format "%4d" (setq id (1+ id)))))
(org-overlay-before-string ov str 'org-special-keyword 'evaporate)
(when hline
- (setq ic 0)
- (while (re-search-forward "[+|]\\(-+\\)" eol t)
- (setq beg (1+ (match-beginning 0))
- ic (1+ ic)
- s1 (concat "$" (int-to-string ic))
- s2 (org-number-to-letters ic)
- str (if (eq org-table-use-standard-references t) s2 s1))
- (setq ov (make-overlay beg (+ beg (length str))))
- (push ov org-table-coordinate-overlays)
- (org-overlay-display ov str 'org-special-keyword 'evaporate)))
- (beginning-of-line 2)))))
+ (let ((ic 0))
+ (while (re-search-forward "[+|]\\(-+\\)" eol t)
+ (cl-incf ic)
+ (let* ((beg (1+ (match-beginning 0)))
+ (s1 (format "$%d" ic))
+ (s2 (org-number-to-letters ic))
+ (str (if (eq t org-table-use-standard-references) s2 s1))
+ (ov (make-overlay beg (+ beg (length str)))))
+ (push ov org-table-coordinate-overlays)
+ (org-overlay-display ov str 'org-special-keyword 'evaporate)))))
+ (forward-line)))))
;;;###autoload
(defun org-table-toggle-coordinate-overlays ()
@@ -4248,8 +4577,8 @@ FACE, when non-nil, for the highlight."
(setq org-table-overlay-coordinates (not org-table-overlay-coordinates))
(message "Tables Row/Column numbers display turned %s"
(if org-table-overlay-coordinates "on" "off"))
- (if (and (org-at-table-p) org-table-overlay-coordinates)
- (org-table-align))
+ (when (and (org-at-table-p) org-table-overlay-coordinates)
+ (org-table-align))
(unless org-table-overlay-coordinates
(mapc 'delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)))
diff --git a/lisp/org.el b/lisp/org.el
index 2680cee..4ba4d8e 100644
--- a/lisp/org.el
+++ b/lisp/org.el
@@ -19629,6 +19629,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names."
(org-defkey org-mode-map "\C-j" 'org-return-indent)
(org-defkey org-mode-map "\C-c?" 'org-table-field-info)
(org-defkey org-mode-map "\C-c " 'org-table-blank-field)
+(org-defkey org-mode-map (kbd "C-c TAB") #'org-table-toggle-column-width)
(org-defkey org-mode-map "\C-c+" 'org-table-sum)
(org-defkey org-mode-map "\C-c=" 'org-table-eval-formula)
(org-defkey org-mode-map "\C-c'" 'org-edit-special)
@@ -21237,7 +21238,8 @@ an argument, unconditionally call `org-insert-heading'."
["Move Column Left" org-metaleft (org-at-table-p)]
["Move Column Right" org-metaright (org-at-table-p)]
["Delete Column" org-shiftmetaleft (org-at-table-p)]
- ["Insert Column" org-shiftmetaright (org-at-table-p)])
+ ["Insert Column" org-shiftmetaright (org-at-table-p)]
+ ["Shrink Column" org-table-toggle-column-width (org-at-table-p)])
("Row"
["Move Row Up" org-metaup (org-at-table-p)]
["Move Row Down" org-metadown (org-at-table-p)]
diff --git a/testing/lisp/test-org-table.el b/testing/lisp/test-org-table.el
index 63234e3..fb782bd 100644
--- a/testing/lisp/test-org-table.el
+++ b/testing/lisp/test-org-table.el
@@ -2232,6 +2232,224 @@ is t, then new columns should be added as needed"
+;;; Shrunk columns
+
+(ert-deftest test-org-table/toggle-column-width ()
+ "Test `org-table-toggle-columns-width' specifications."
+ ;; Error when not at a column.
+ (should-error
+ (org-test-with-temp-text "<point>a"
+ (org-table-toggle-column-width)))
+ (should-error
+ (org-test-with-temp-text "| a |"
+ (org-table-toggle-column-width)))
+ (should-error
+ (org-test-with-temp-text "| a |<point>"
+ (org-table-toggle-column-width)))
+ ;; A shrunk columns is overlaid with
+ ;; `org-table-shrunk-column-indicator'.
+ (should
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (point))) 'display))))
+ (should
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| a |\n|-<point>--|"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (point))) 'display))))
+ ;; Shrink every field in the same column.
+ (should
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| a |\n|-<point>--|"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (1+ (line-beginning-position 0))))
+ 'display))))
+ ;; When column is already shrunk, expand it, i.e., remove overlays.
+ (should-not
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (org-table-toggle-column-width)
+ (overlays-in (point-min) (point-max)))))
+ (should-not
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| a |\n| <point>b |"
+ (org-table-toggle-column-width)
+ (org-table-toggle-column-width)
+ (overlays-in (point-min) (point-max)))))
+ ;; With a column width cookie, limit overlay to the specified number
+ ;; of characters.
+ (should
+ (equal (concat " abc" org-table-shrunk-column-indicator)
+ (org-test-with-temp-text "| <3> |\n| <point>abcd |"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (point))) 'display))))
+ (should
+ (equal (concat " a " org-table-shrunk-column-indicator)
+ (org-test-with-temp-text "| <3> |\n| <point>a |"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (point))) 'display))))
+ ;; Only overlay visible characters of the field.
+ (should
+ (equal (concat " htt" org-table-shrunk-column-indicator)
+ (org-test-with-temp-text "| <3> |\n| <point>[[http://orgmode.org]] |"
+ (org-table-toggle-column-width)
+ (overlay-get (car (overlays-at (point))) 'display))))
+ ;; With optional argument ARG, toggle specified columns.
+ (should
+ (equal org-table-shrunk-column-indicator
+ (org-test-with-temp-text "| <point>a | b |"
+ (org-table-toggle-column-width "2")
+ (overlay-get (car (overlays-at (- (point-max) 2))) 'display))))
+ (should
+ (equal '("b" "c")
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "2-3")
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("b" "c" "d")
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "2-")
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("a" "b")
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "-2")
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("a" "b" "c" "d")
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "-")
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("a" "d")
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "1-3")
+ (org-table-toggle-column-width "2-4")
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; When ARG is (16), remove any column overlay.
+ (should-not
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (org-table-toggle-column-width '(16))
+ (overlays-in (point-min) (point-max))))
+ (should-not
+ (org-test-with-temp-text "| a | b | c | d |"
+ (org-table-toggle-column-width "-")
+ (org-table-toggle-column-width '(16))
+ (overlays-in (point-min) (point-max)))))
+
+(ert-deftest test-org-table/shrunk-columns ()
+ "Test behaviour of shrunk column."
+ ;; Edition automatically expands a shrunk column.
+ (should-not
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (insert "a")
+ (overlays-in (point-min) (point-max))))
+ ;; Other columns are not changed.
+ (should
+ (org-test-with-temp-text "| <point>a | b |"
+ (org-table-toggle-column-width "-")
+ (insert "a")
+ (overlays-in (point-min) (point-max))))
+ ;; Moving a shrunk column doesn't alter its state.
+ (should
+ (equal "a"
+ (org-test-with-temp-text "| <point>a | b |"
+ (org-table-toggle-column-width)
+ (org-table-move-column-right)
+ (overlay-get (car (overlays-at (point))) 'help-echo))))
+ (should
+ (equal "a"
+ (org-test-with-temp-text "| <point>a |\n| b |"
+ (org-table-toggle-column-width)
+ (org-table-move-row-down)
+ (overlay-get (car (overlays-at (point))) 'help-echo))))
+ ;; State is preserved upon inserting a column.
+ (should
+ (equal '("a")
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (org-table-insert-column)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; State is preserved upon deleting a column.
+ (should
+ (equal '("a" "c")
+ (org-test-with-temp-text "| a | <point>b | c |"
+ (org-table-toggle-column-width "-")
+ (org-table-delete-column)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; State is preserved upon deleting a row.
+ (should
+ (equal '("b1" "b2")
+ (org-test-with-temp-text "| a1 | a2 |\n| b1 | b2 |"
+ (org-table-toggle-column-width "-")
+ (org-table-kill-row)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("a1" "a2")
+ (org-test-with-temp-text "| a1 | a2 |\n| <point>b1 | b2 |"
+ (org-table-toggle-column-width "-")
+ (org-table-kill-row)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; State is preserved upon inserting a row or hline.
+ (should
+ (equal '("" "a1" "b1")
+ (org-test-with-temp-text "| a1 | a2 |\n| <point>b1 | b2 |"
+ (org-table-toggle-column-width)
+ (org-table-insert-row)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ (should
+ (equal '("a1" "b1")
+ (org-test-with-temp-text "| a1 | a2 |\n| <point>b1 | b2 |"
+ (org-table-toggle-column-width)
+ (org-table-insert-hline)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; State is preserved upon sorting a column for all the columns but
+ ;; the one being sorted.
+ (should
+ (equal '("a2" "b2")
+ (org-test-with-temp-text "| <point>a1 | a2 |\n| <point>b1 | b2 |"
+ (org-table-toggle-column-width "-")
+ (org-table-sort-lines nil ?A)
+ (sort (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))
+ #'string-lessp))))
+ ;; State is preserved upon replacing a field non-interactively.
+ (should
+ (equal '("a")
+ (org-test-with-temp-text "| <point>a |"
+ (org-table-toggle-column-width)
+ (org-table-get-field nil "b")
+ (mapcar (lambda (o) (overlay-get o 'help-echo))
+ (overlays-in (point-min) (point-max)))))))
+
+
+
;;; Miscellaneous
(ert-deftest test-org-table/get-field ()