Function: org-table--shrink-field

org-table--shrink-field is a byte-compiled function defined in org-table.el.gz.

Signature

(org-table--shrink-field WIDTH ALIGN START END CONTENTS)

Documentation

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. ALIGN is the alignment of the current column, as either "l",
"c" or "r". 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 one or two overlays. They have the following properties:

  org-overlay-type

    Set to table-column-hide. Used to identify overlays
    responsible for shrinking columns in a table.

  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 a list of overlays hiding the field, or nil if field is already hidden.

Source Code

;; Defined in /usr/src/emacs/lisp/org/org-table.el.gz
(defun org-table--shrink-field (width align 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'.
ALIGN is the alignment of the current column, as either \"l\",
\"c\" or \"r\".  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 one or two overlays.  They have the
following properties:

  `org-overlay-type'

    Set to `table-column-hide'.  Used to identify overlays
    responsible for shrinking columns in a table.

  `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 a list of overlays hiding the field, or nil if field is
already hidden."
  (cond
   ((= start end) nil)			;no field to narrow
   ((org-table--shrunk-field) nil)	;already shrunk
   ((= 0 width)				;shrink to one character
    (list (org-table--make-shrinking-overlay
	   start end "" (if (eq 'hline contents) "" contents))))
   ((eq contents 'hline)
    (list (org-table--make-shrinking-overlay
	   start end (make-string (1+ width) ?-) "")))
   ((equal contents "")			;no contents to hide
    (list
     (let ((w (org-string-width (buffer-substring start end) nil 'org-table))
	   ;; We really want WIDTH + 2 whitespace, to include blanks
	   ;; around fields.
	   (full (+ 2 width)))
       (if (<= w full)
	   (org-table--make-shrinking-overlay
	    (1- end) end (make-string (- full w) ?\s) "")
	 (org-table--make-shrinking-overlay (- end (- w full) 1) end "" "")))))
   (t
    ;; If the field is not empty, display exactly WIDTH characters.
    ;; It can mean to partly hide the field, or extend it with virtual
    ;; blanks.  To that effect, we use one or two overlays.  The
    ;; first, optional, one may add or hide white spaces before the
    ;; contents of the field.  The other, mandatory, one cuts the
    ;; field or displays white spaces at the end of the field.  It
    ;; also always displays `org-table-shrunk-column-indicator'.
    (let* ((lead (org-with-point-at start (skip-chars-forward " ")))
	   (trail (org-with-point-at end (abs (skip-chars-backward " "))))
	   (contents-width (org-string-width
			    (buffer-substring (+ start lead) (- end trail))
                            nil 'org-table)))
      (cond
       ;; Contents are too large to fit in WIDTH character.  Limit, if
       ;; possible, blanks at the beginning of the field to a single
       ;; white space, and cut the field at an appropriate location.
       ((<= width contents-width)
	(let ((pre
	       (and (> lead 0)
		    (org-table--make-shrinking-overlay
		     start (+ start lead) "" contents t)))
	      (post
	       (org-table--make-shrinking-overlay
		;; Find cut location so that WIDTH characters are
		;; visible using dichotomy.
		(let* ((begin (+ start lead))
		       (lower begin)
		       (upper (1- end))
		       ;; Compensate the absence of leading space,
		       ;; thus preserving alignment.
		       (width (if (= lead 0) (1+ width) width)))
		  (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) nil 'org-table)
			  ((pred (= width)) (throw :exit mean))
			  ((pred (< width)) (setq upper mean))
			  (_ (setq lower mean)))))
		    upper))
		end "" contents)))
	  (if pre (list pre post) (list post))))
       ;; Contents fit it WIDTH characters.  First compute number of
       ;; white spaces needed on each side of contents, then expand or
       ;; compact blanks on each side of the field in order to
       ;; preserve width and obey to alignment constraints.
       (t
	(let* ((required (- width contents-width))
	       (before
		(pcase align
		  ;; Compensate the absence of leading space, thus
		  ;; preserving alignment.
		  ((guard (= lead 0)) -1)
		  ("l" 0)
		  ("r" required)
		  ("c" (/ required 2))))
	       (after (- required before))
	       (pre
		(pcase (1- lead)
		  ((or (guard (= lead 0)) (pred (= before))) nil)
		  ((pred (< before))
		   (org-table--make-shrinking-overlay
		    start (+ start (- lead before)) "" contents t))
		  (_
		   (org-table--make-shrinking-overlay
		    start (1+ start)
		    (make-string (- before (1- lead)) ?\s)
		    contents t))))
	       (post
		(pcase (1- trail)
		  ((pred (= after))
		   (org-table--make-shrinking-overlay (1- end) end "" contents))
		  ((pred (< after))
		   (org-table--make-shrinking-overlay
		    (+ after (- end trail)) end "" contents))
		  (_
		   (org-table--make-shrinking-overlay
		    (1- end) end
		    (make-string (- after (1- trail)) ?\s)
		    contents)))))
	  (if pre (list pre post) (list post)))))))))