forked from mirrors/org-mode
Allow editing partially shrunk columns
* lisp/org-table.el (org-table-with-shrunk-field): New macro. (org-table-get-field): (org-table-toggle-column-width): Use new macro. (org-table--shrunk-field): Update function. (org-table--shrink-field): When there is a width cookie, leave first characters editable. * lisp/org.el (org-self-insert-command): (org-delete-backward-char): (org-delete-char): Small refactoring. Handle shrink overlays. * testing/lisp/test-org-table.el (test-org-table/toggle-column-width): Update tests.
This commit is contained in:
Nicolas Goaziou
parent
5411435633
commit
33a9eef11f
|
|
@ -526,6 +526,17 @@ Field is restored even in case of abnormal exit."
|
|||
(org-table-goto-column ,column)
|
||||
(set-marker ,line nil)))))
|
||||
|
||||
(defmacro org-table-with-shrunk-field (&rest body)
|
||||
"Save field shrunk state, execute BODY and restore state."
|
||||
(declare (debug (body)))
|
||||
(org-with-gensyms (end shrunk size)
|
||||
`(let* ((,shrunk (save-match-data (org-table--shrunk-field)))
|
||||
(,end (and ,shrunk (copy-marker (overlay-end ,shrunk) t)))
|
||||
(,size (and ,shrunk (- ,end (overlay-start ,shrunk)))))
|
||||
(when ,shrunk (delete-overlay ,shrunk))
|
||||
(unwind-protect (progn ,@body)
|
||||
(when ,shrunk (move-overlay ,shrunk (- ,end ,size) ,end))))))
|
||||
|
||||
(defmacro org-table-with-shrunk-columns (&rest body)
|
||||
"Expand all columns before executing BODY, then shrink them again."
|
||||
(declare (debug (body)))
|
||||
|
|
@ -1265,16 +1276,8 @@ value."
|
|||
(let* ((pos (match-beginning 0))
|
||||
(val (buffer-substring pos (match-end 0))))
|
||||
(when replace
|
||||
;; 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)))))))
|
||||
(org-table-with-shrunk-field
|
||||
(replace-match (if (equal replace "") " " replace) t t)))
|
||||
(goto-char (min (line-end-position) (1+ pos)))
|
||||
val)))
|
||||
|
||||
|
|
@ -3838,7 +3841,9 @@ 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)))))
|
||||
(overlays-at (save-excursion
|
||||
(skip-chars-forward "^|" (line-end-position))
|
||||
(1- (point))))))
|
||||
|
||||
(defun org-table--list-shrunk-columns ()
|
||||
"List currently shrunk columns in table at point."
|
||||
|
|
@ -3898,38 +3903,38 @@ 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."
|
||||
Return overlay hiding 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)))
|
||||
(let* ((overlay-start
|
||||
(cond
|
||||
((= 0 width) start) ;hide everything
|
||||
((<= (- end start) 1) start) ;column too short
|
||||
((>= width (- end start)) (1- end)) ;enough room
|
||||
((eq contents 'hline) (+ start width))
|
||||
(t
|
||||
;; Find cut location so that WIDTH characters are
|
||||
;; visible.
|
||||
(let* ((begin start)
|
||||
(lower begin)
|
||||
(upper (1- end)))
|
||||
(catch :exit
|
||||
(while (> (- upper lower) 1)
|
||||
(let ((mean (+ (ash lower -1)
|
||||
(ash upper -1)
|
||||
(logand lower upper 1))))
|
||||
(pcase (org-string-width (buffer-substring begin mean))
|
||||
((pred (= width)) (throw :exit mean))
|
||||
((pred (< width)) (setq upper mean))
|
||||
(_ (setq lower mean)))))
|
||||
upper)))))
|
||||
(display 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 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)
|
||||
|
|
@ -4069,10 +4074,8 @@ prefix, expand all columns."
|
|||
(`(16) (org-table-expand begin end))
|
||||
(_
|
||||
(org-table-expand begin end)
|
||||
(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))))))))
|
||||
(org-table--shrink-columns
|
||||
(cl-set-exclusive-or columns shrunk) begin end)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun org-table-shrink (&optional begin end)
|
||||
|
|
|
|||
78
lisp/org.el
78
lisp/org.el
|
|
@ -19235,12 +19235,13 @@ overwritten, and the table is not marked as requiring realignment."
|
|||
(t (let (org-use-speed-commands)
|
||||
(call-interactively 'org-self-insert-command)))))
|
||||
((and
|
||||
(org-at-table-p)
|
||||
(eq N 1)
|
||||
(= N 1)
|
||||
(not (org-region-active-p))
|
||||
(org-at-table-p)
|
||||
(progn
|
||||
;; Check if we blank the field, and if that triggers align.
|
||||
(and (featurep 'org-table) org-table-auto-blank-field
|
||||
(and (featurep 'org-table)
|
||||
org-table-auto-blank-field
|
||||
(memq last-command
|
||||
'(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c))
|
||||
(if (or (eq (char-after) ?\s) (looking-at "[^|\n]* |"))
|
||||
|
|
@ -19251,10 +19252,16 @@ overwritten, and the table is not marked as requiring realignment."
|
|||
;; width.
|
||||
(org-table-blank-field)))
|
||||
t)
|
||||
(looking-at "[^|\n]* \\( \\)|"))
|
||||
(looking-at "[^|\n]* |"))
|
||||
;; There is room for insertion without re-aligning the table.
|
||||
(delete-region (match-beginning 1) (match-end 1))
|
||||
(self-insert-command N))
|
||||
(self-insert-command N)
|
||||
(org-table-with-shrunk-field
|
||||
(save-excursion
|
||||
(skip-chars-forward "^|")
|
||||
;; Do not delete last space, which is
|
||||
;; `org-table-separator-space', but the regular space before
|
||||
;; it.
|
||||
(delete-region (- (point) 2) (1- (point))))))
|
||||
(t
|
||||
(setq org-table-may-need-update t)
|
||||
(self-insert-command N)
|
||||
|
|
@ -19355,22 +19362,14 @@ because, in this case the deletion might narrow the column."
|
|||
(interactive "p")
|
||||
(save-match-data
|
||||
(org-check-before-invisible-edit 'delete-backward)
|
||||
(if (and (org-at-table-p)
|
||||
(eq N 1)
|
||||
(if (and (= N 1)
|
||||
(not overwrite-mode)
|
||||
(not (org-region-active-p))
|
||||
(string-match "|" (buffer-substring (point-at-bol) (point)))
|
||||
(looking-at ".*?|"))
|
||||
(let ((pos (point))
|
||||
(noalign (looking-at "[^|\n\r]* |"))
|
||||
(c org-table-may-need-update))
|
||||
(backward-delete-char N)
|
||||
(unless overwrite-mode
|
||||
(skip-chars-forward "^|")
|
||||
(insert " ")
|
||||
(goto-char (1- pos)))
|
||||
;; noalign: if there were two spaces at the end, this field
|
||||
;; does not determine the width of the column.
|
||||
(when noalign (setq org-table-may-need-update c)))
|
||||
(not (eq (char-before) ?|))
|
||||
(save-excursion (skip-chars-backward " \t") (not (bolp)))
|
||||
(looking-at-p ".*?|")
|
||||
(org-at-table-p))
|
||||
(progn (forward-char -1) (org-delete-char 1))
|
||||
(backward-delete-char N)
|
||||
(org-fix-tags-on-the-fly))))
|
||||
|
||||
|
|
@ -19383,23 +19382,28 @@ because, in this case the deletion might narrow the column."
|
|||
(interactive "p")
|
||||
(save-match-data
|
||||
(org-check-before-invisible-edit 'delete)
|
||||
(if (and (org-at-table-p)
|
||||
(not (bolp))
|
||||
(not (= (char-after) ?|))
|
||||
(eq N 1))
|
||||
(if (looking-at ".*?|")
|
||||
(let ((pos (point))
|
||||
(noalign (looking-at "[^|\n\r]* |"))
|
||||
(c org-table-may-need-update))
|
||||
(replace-match
|
||||
(concat (substring (match-string 0) 1 -1) " |") nil t)
|
||||
(goto-char pos)
|
||||
;; noalign: if there were two spaces at the end, this field
|
||||
;; does not determine the width of the column.
|
||||
(when noalign (setq org-table-may-need-update c)))
|
||||
(delete-char N))
|
||||
(cond
|
||||
((or (/= N 1)
|
||||
(eq (char-after) ?|)
|
||||
(save-excursion (skip-chars-backward " \t") (bolp))
|
||||
(not (org-at-table-p)))
|
||||
(delete-char N)
|
||||
(org-fix-tags-on-the-fly))))
|
||||
(org-fix-tags-on-the-fly))
|
||||
((looking-at ".\\(.*?\\)|")
|
||||
(let* ((update? org-table-may-need-update)
|
||||
(noalign (looking-at-p ".*? |")))
|
||||
(delete-char 1)
|
||||
(org-table-with-shrunk-field
|
||||
(save-excursion
|
||||
;; Last space is `org-table-separator-space', so insert
|
||||
;; a regular one before it instead.
|
||||
(goto-char (- (match-end 0) 2))
|
||||
(insert " ")))
|
||||
;; If there were two spaces at the end, this field does not
|
||||
;; determine the width of the column.
|
||||
(when noalign (setq org-table-may-need-update update?))))
|
||||
(t
|
||||
(delete-char N)))))
|
||||
|
||||
;; Make `delete-selection-mode' work with Org mode and Orgtbl mode
|
||||
(put 'org-self-insert-command 'delete-selection
|
||||
|
|
|
|||
|
|
@ -2401,21 +2401,30 @@ See also `test-org-table/copy-field'."
|
|||
;; 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 |"
|
||||
(equal "| ab"
|
||||
(org-test-with-temp-text "| <3> |\n| <point>abcd |"
|
||||
(org-table-toggle-column-width)
|
||||
(overlay-get (car (overlays-at (point))) 'display))))
|
||||
(buffer-substring (line-beginning-position)
|
||||
(overlay-start
|
||||
(car (overlays-in (line-beginning-position)
|
||||
(line-end-position))))))))
|
||||
(should
|
||||
(equal (concat " a " org-table-shrunk-column-indicator)
|
||||
(org-test-with-temp-text "| <3> |\n| <point>a |"
|
||||
(equal "| a "
|
||||
(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.
|
||||
(buffer-substring (line-beginning-position)
|
||||
(overlay-start
|
||||
(car (overlays-in (line-beginning-position)
|
||||
(line-end-position))))))))
|
||||
;; Width only takes into account visible characters.
|
||||
(should
|
||||
(equal (concat " htt" org-table-shrunk-column-indicator)
|
||||
(org-test-with-temp-text "| <3> |\n| <point>[[http://orgmode.org]] |"
|
||||
(equal "| [[htt"
|
||||
(org-test-with-temp-text "| <4> |\n| <point>[[http://orgmode.org]] |"
|
||||
(org-table-toggle-column-width)
|
||||
(overlay-get (car (overlays-at (point))) 'display))))
|
||||
(buffer-substring (line-beginning-position)
|
||||
(overlay-start
|
||||
(car (overlays-in (line-beginning-position)
|
||||
(line-end-position))))))))
|
||||
;; Before the first column or after the last one, ask for columns
|
||||
;; ranges.
|
||||
(should
|
||||
|
|
|
|||
Loading…
Reference in New Issue