Add pre-redisplay-function and rectangular region

* lisp/rect.el: Use lexical-binding.  Add new rectangular region support.
(rectangle-mark): New command.
(rectangle--region): New var.
(deactivate-mark-hook): Reset rectangle--region.
(rectangle--extract-region, rectangle--insert-for-yank)
(rectangle--highlight-for-redisplay)
(rectangle--unhighlight-for-redisplay): New functions.
(region-extract-function, redisplay-unhighlight-region-function)
(redisplay-highlight-region-function): Use them to handle
rectangular region.
* lisp/simple.el (region-extract-function): New var.
(delete-backward-char, delete-forward-char, deactivate-mark): Use it.
(kill-new, kill-append): Remove obsolete `yank-handler' argument.
(kill-region): Replace obsolete `yank-handler' arg with `region'.
(copy-region-as-kill, kill-ring-save): Add `region' argument.
(redisplay-unhighlight-region-function)
(redisplay-highlight-region-function): New vars.
(redisplay--update-region-highlight): New function.
(pre-redisplay-function): Use it.
(exchange-point-and-mark): Don't deactivate the mark before
reactivate-it anyway.
* lisp/comint.el (comint-kill-region): Remove yank-handler argument.
* lisp/delsel.el (delete-backward-char, backward-delete-char-untabify)
(delete-char): Remove property, since it's now part of their
default behavior.
(self-insert-iso): Remove property since this command doesn't exist.

* src/xdisp.c (prepare_menu_bars): Call Vpre_redisplay_function.
(syms_of_xdisp): Declare pre-redisplay-function.
(markpos_of_region): Remove function.
(init_iterator, compute_stop_pos, handle_face_prop)
(face_before_or_after_it_pos, reseat_to_string)
(get_next_display_element, window_buffer_changed)
(redisplay_internal, try_cursor_movement, redisplay_window)
(try_window_reusing_current_matrix, try_window_id, display_line)
(note_mode_line_or_margin_highlight, note_mouse_highlight)
(display_string, mouse_face_from_buffer_pos): Remove region handling.
* src/window.h (struct window): Remove field `region_showing'.
* src/dispextern.h (struct it): Remove region_beg/end_charpos.
(face_at_buffer_position, face_for_overlay_string)
(face_at_string_position): Update prototypes.
* src/xfaces.c (face_at_buffer_position, face_for_overlay_string)
(face_at_string_position): Remove `region_beg' and `region_end' args.
* src/fontset.c (Finternal_char_font):
* src/font.c (font_at, font_range): Adjust calls accordingly.
* src/insdel.c (Qregion_extract_function): New var.
(syms_of_insdel): Initialize it.
(prepare_to_modify_buffer_1): Use it.

1 files changed, 147 insertions, 1 deletions

diff --git a/lisp/rect.el b/lisp/rect.el
index ec234b6514f..44799f2616a 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -1,4 +1,4 @@
-;;; rect.el --- rectangle functions for GNU Emacs
+;;; rect.el --- rectangle functions for GNU Emacs  -*- lexical-binding:t -*-
 
 ;; Copyright (C) 1985, 1999-2013 Free Software Foundation, Inc.
 
@@ -412,6 +412,152 @@ with a prefix argument, prompt for START-AT and FORMAT."
     (apply-on-rectangle 'rectangle-number-line-callback
 			start end format)))
 
+;;; New rectangle integration with kill-ring.
+
+;; FIXME: lots of known problems with the new rectangle support:
+;; - no key binding for mark-rectangle.
+;; - no access to the `string-rectangle' functionality.
+;; - lots of commands handle the region without paying attention to its
+;;   rectangular shape.
+
+(defvar-local rectangle--region nil
+  "If non-nil, the region is meant to delimit a rectangle.")
+
+(add-hook 'deactivate-mark-hook
+          (lambda () (kill-local-variable 'rectangle--region)))
+
+(add-function :around redisplay-highlight-region-function
+              #'rectangle--highlight-for-redisplay)
+(add-function :around redisplay-unhighlight-region-function
+              #'rectangle--unhighlight-for-redisplay)
+(add-function :around region-extract-function
+              #'rectangle--extract-region)
+
+;;;###autoload
+(defun rectangle-mark ()
+  "Toggle the region as rectangular."
+  (interactive)
+  (if rectangle--region
+      (kill-local-variable 'rectangle--region)
+    (unless (region-active-p) (push-mark-command t))
+    (setq rectangle--region t)))
+
+(defun rectangle--extract-region (orig &optional delete)
+  (if (not rectangle--region)
+      (funcall orig delete)
+    (let* ((strs (funcall (if delete
+                              #'delete-extract-rectangle
+                            #'extract-rectangle)
+                          (region-beginning) (region-end)))
+           (str (mapconcat #'identity strs "\n")))
+      (when (eq last-command 'kill-region)
+        ;; Try to prevent kill-region from appending this to some
+        ;; earlier element.
+        (setq last-command 'kill-region-dont-append))
+      (when strs
+        (put-text-property 0 (length str) 'yank-handler
+                           `(rectangle--insert-for-yank ,strs t)
+                           str)
+        str))))
+
+(defun rectangle--insert-for-yank (strs)
+  (push (point) buffer-undo-list)
+  (let ((undo-at-start buffer-undo-list))
+    (insert-rectangle strs)
+    (setq yank-undo-function
+          (lambda (_start _end)
+            (undo-start)
+            (setcar undo-at-start nil)  ;Turn it into a boundary.
+            (while (not (eq pending-undo-list (cdr undo-at-start)))
+              (undo-more 1))))))
+
+(defun rectangle--highlight-for-redisplay (orig start end window rol)
+  (cond
+   ((not rectangle--region)
+    (funcall orig start end window rol))
+   ((and (eq 'rectangle (car-safe rol))
+         (eq (nth 1 rol) (buffer-modified-tick))
+         (eq start (nth 2 rol))
+         (eq end (nth 3 rol)))
+    rol)
+   (t
+    (save-excursion
+      (let* ((nrol nil)
+             (old (if (eq 'rectangle (car-safe rol))
+                      (nthcdr 4 rol)
+                    (funcall redisplay-unhighlight-region-function rol)
+                    nil))
+             (ptcol (progn (goto-char start) (current-column)))
+             (markcol (progn (goto-char end) (current-column)))
+             (leftcol  (min ptcol markcol))
+             (rightcol (max ptcol markcol)))
+        (goto-char start)
+        (while (< (point) end)
+          (let* ((mleft (move-to-column leftcol))
+                 (left (point))
+                 (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
+                           (spaces-string (- leftcol mleft)))
+              (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
+                           (spaces-string (- leftcol (current-column)))))
+             ((overlay-get ol 'before-string)
+              (overlay-put ol 'before-string nil)))
+            (cond
+             ((< mright rightcol)       ;`rightcol' is past EOL.
+              (let ((str (make-string (- rightcol mright) ?\s)))
+                (put-text-property 0 (length str) 'face 'region str)
+                ;; If cursor happens to be here, draw it *before* rather than
+                ;; after this highlighted pseudo-text.
+                (put-text-property 0 1 'cursor t str)
+                (overlay-put ol 'after-string str)))
+             ((and (> mright rightcol)  ;`rightcol' is in the middle of a char.
+                   (eq (char-before right) ?\t))
+              (setq right (1- right))
+              (move-overlay ol left right)
+              (goto-char right)
+              (let ((str (make-string (- rightcol (current-column)) ?\s)))
+                (put-text-property 0 (length str) 'face 'region str)
+                (overlay-put ol 'after-string str)))
+             ((overlay-get ol 'after-string)
+              (overlay-put ol 'after-string nil)))
+            (when (= leftcol rightcol)
+              ;; 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))
+          (forward-line 1))
+        (mapc #'delete-overlay old)
+        `(rectangle ,(buffer-modified-tick) ,start ,end ,@nrol))))))
+
+(defun rectangle--unhighlight-for-redisplay (orig rol)
+  (if (not (eq 'rectangle (car-safe rol)))
+      (funcall orig rol)
+    (mapc #'delete-overlay (nthcdr 4 rol))
+    (setcar (cdr rol) nil)))
+
 (provide 'rect)
 
 ;;; rect.el ends here