Function: org-table--shrink-columns

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

Signature

(org-table--shrink-columns COLUMNS BEG END)

Documentation

Shrink COLUMNS in a table.

COLUMNS is a sorted list of column numbers. BEG and END are, respectively, the beginning position and the end position of the table.

Source Code

;; Defined in /usr/src/emacs/lisp/org/org-table.el.gz
(defun org-table--shrink-columns (columns beg end)
  "Shrink COLUMNS in a 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 ((align nil)
	   (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 (not hline?)
			  (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)>\\'"
					contents))
		 (unless align (setq align (match-string 1 contents)))
		 (unless width
		   (setq width (string-to-number (match-string 2 contents))))))))
	 (forward-line))
       ;; Link overlays for current field to the other overlays in the
       ;; same column.
       (let ((chain (list 'siblings)))
	 (dolist (field fields)
	   (dolist (new (apply #'org-table--shrink-field
			       (or width 0) (or align "l") field))
	     (push new (cdr chain))
	     (overlay-put new 'org-table-column-overlays chain))))))))