Function: rectangle--highlight-for-redisplay

rectangle--highlight-for-redisplay is a byte-compiled function defined in rect.el.gz.

Signature

(rectangle--highlight-for-redisplay ORIG START END WINDOW ROL)

Source Code

;; Defined in /usr/src/emacs/lisp/rect.el.gz
(defun rectangle--highlight-for-redisplay (orig start end window rol)
  (cond
   ((not rectangle-mark-mode)
    (funcall orig start end window rol))
   (rectangle--inhibit-region-highlight
    (funcall redisplay-unhighlight-region-function rol)
    nil)
   ((and (eq 'rectangle (car-safe rol))
         (eq (nth 1 rol) (buffer-chars-modified-tick))
         (eq start (nth 2 rol))
         (eq end (nth 3 rol))
         (equal (rectangle--crutches) (nth 4 rol))
         ;; Check point explicitly so that `exchange-point-and-mark'
         ;; triggers overlay recomputation.
         (eq (nth 5 rol) (point)))
    rol)
   (t
    (save-excursion
      (let* ((pt (point))
             (nrol nil)
             (old (if (eq 'rectangle (car-safe rol))
                      (nthcdr 6 rol)
                    (funcall redisplay-unhighlight-region-function rol)
                    nil)))
        (cl-assert (eq (window-buffer window) (current-buffer)))
        ;; `rectangle--pos-cols' looks up the `selected-window's parameter!
        (with-selected-window window
          (let* ((cols (rectangle--pos-cols start end))
                 (startcol (car cols))
                 (endcol (cdr cols))
                 (leftcol (min startcol endcol))
                 (rightcol (max startcol endcol))
                 ;; We don't know what lines will actually be displayed,
                 ;; so add highlight overlays on lines within the window
                 ;; height from point.
                 (height (window-height))
                 (start-pt (max start (progn (forward-line (- height))
                                             (point))))
                 (end-pt (min end (progn (goto-char pt)
                                         (forward-line height)
                                         (point)))))
            (goto-char start-pt)
            (beginning-of-line)
            (while
                (let* ((mleft (move-to-column leftcol))
                       (left (point))
                       ;; BEWARE: In the presence of other overlays with
                       ;; before/after/display-strings, this happens to move to
                       ;; the column "as if the overlays were not applied",
                       ;; which is sometimes what we want, tho it can be
                       ;; considered a bug in move-to-column (it should
                       ;; arguably pay attention to the
                       ;; before/after-string/display properties when computing
                       ;; the column).
                       (mright (move-to-column rightcol))
                       (right (point))
                       (ol
                        (if (not old)
                            (let ((ol (make-overlay left right)))
                              (overlay-put ol 'window window)
                              (overlay-put ol 'face 'region)
                              ol)
                          (let ((ol (pop old)))
                            (move-overlay ol left right (current-buffer))
                            ol))))
                  ;; `move-to-column' may stop before the column (if bumping
                  ;; into EOL) or overshoot it a little, when column is in the
                  ;; middle of a char.
                  (cond
                   ((< mleft leftcol)      ;`leftcol' is past EOL.
                    (overlay-put ol 'before-string
                                 (rectangle--space-to leftcol))
                    (setq mright (max mright leftcol)))
                   ((and (> mleft leftcol) ;`leftcol' is in the middle of a char
                         (eq (char-before left) ?\t))
                    (setq left (1- left))
                    (move-overlay ol left right)
                    (goto-char left)
                    (overlay-put ol 'before-string
                                 (rectangle--space-to leftcol)))
                   ((overlay-get ol 'before-string)
                    (overlay-put ol 'before-string nil)))
                  (cond
                   ;; While doing rectangle--string-preview, the two sets of
                   ;; overlays steps on the other's toes.  I fixed some of the
                   ;; problems, but others remain.  The main one is the two
                   ;; (rectangle--space-to rightcol) below which try to
                   ;; virtually insert missing text, but during "preview", the
                   ;; text is not missing (it's provided by preview's own
                   ;; overlay).
                   (rectangle--string-preview-state
                    (if (overlay-get ol 'after-string)
                        (overlay-put ol 'after-string nil)))
                   ((< mright rightcol)    ;`rightcol' is past EOL.
                    (let ((str (rectangle--space-to rightcol)))
                      (put-text-property 0 (length str) 'face 'region str)
                      ;; If cursor happens to be here, draw it at the right
                      ;; place.
                      (rectangle--place-cursor leftcol left str)
                      (overlay-put ol 'after-string str)))
                   ((and (> mright rightcol) ;`rightcol' in the middle of a char
                         (eq (char-before right) ?\t))
                    (setq right (1- right))
                    (move-overlay ol left right)
                    (if (= rightcol leftcol)
                        (overlay-put ol 'after-string nil)
                      (goto-char right)
                      (let ((str (rectangle--space-to rightcol)))
                        (put-text-property 0 (length str) 'face 'region str)
                        (when (= left right)
                          (rectangle--place-cursor leftcol left str))
                        (overlay-put ol 'after-string str))))
                   ((overlay-get ol 'after-string)
                    (overlay-put ol 'after-string nil)))
                  (when (and (= leftcol rightcol) (display-graphic-p)
                             rectangle-indicate-zero-width-rectangle)
                    ;; Make zero-width rectangles visible!
                    (overlay-put ol 'after-string
                                 (concat (propertize
                                          " " 'face '(region (:height 0.2)))
                                         (overlay-get ol 'after-string))))
                  (push ol nrol)
                  (and (zerop (forward-line 1))
                       (bolp)
                       (<= (point) end-pt))))
            )
          )
        (mapc #'delete-overlay old)
        `(rectangle ,(buffer-chars-modified-tick)
                    ,start ,end ,(rectangle--crutches) ,pt
                    ,@nrol))))))