X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cbd447e1cdbbebcd2a04144194138bb7936dea9d..3698c4e475fb59730626af5d001599785ef5ef9e:/lisp/rect.el diff --git a/lisp/rect.el b/lisp/rect.el index 75585d2f08..8803a47215 100644 --- a/lisp/rect.el +++ b/lisp/rect.el @@ -1,6 +1,6 @@ ;;; rect.el --- rectangle functions for GNU Emacs -*- lexical-binding:t -*- -;; Copyright (C) 1985, 1999-2015 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1999-2016 Free Software Foundation, Inc. ;; Maintainer: Didier Verna ;; Keywords: internal @@ -257,6 +257,19 @@ Return it as a list of strings, one for each line of the rectangle." (apply-on-rectangle 'extract-rectangle-line start end lines) (nreverse (cdr lines)))) +(defun extract-rectangle-bounds (start end) + "Return the bounds of the rectangle with corners at START and END. +Return it as a list of (START . END) positions, one for each line of +the rectangle." + (let (bounds) + (apply-on-rectangle + (lambda (startcol endcol) + (move-to-column startcol) + (push (cons (prog1 (point) (move-to-column endcol)) (point)) + bounds)) + start end) + (nreverse bounds))) + (defvar killed-rectangle nil "Rectangle for `yank-rectangle' to insert.") @@ -346,7 +359,8 @@ no text on the right side of the rectangle." (defun delete-whitespace-rectangle-line (startcol _endcol fill) (when (= (move-to-column startcol (if fill t 'coerce)) startcol) (unless (= (point) (point-at-eol)) - (delete-region (point) (progn (skip-syntax-forward " ") (point)))))) + (delete-region (point) (progn (skip-syntax-forward " " (point-at-eol)) + (point)))))) ;;;###autoload (defalias 'close-rectangle 'delete-whitespace-rectangle) ;; Old name @@ -356,7 +370,7 @@ no text on the right side of the rectangle." "Delete all whitespace following a specified column in each line. The left edge of the rectangle specifies the position in each line at which whitespace deletion should begin. On each line in the -rectangle, all continuous whitespace starting at that column is deleted. +rectangle, all contiguous whitespace starting at that column is deleted. When called from a program the rectangle's corners are START and END. With a prefix (or a FILL) argument, also fill too short lines." @@ -384,48 +398,51 @@ With a prefix (or a FILL) argument, also fill too short lines." (defun rectangle--space-to (col) (propertize " " 'display `(space :align-to ,col))) -(defface rectangle-preview-face '((t :inherit region)) - "The face to use for the `string-rectangle' preview.") +(defface rectangle-preview '((t :inherit region)) + "The face to use for the `string-rectangle' preview." + :version "25.1") (defcustom rectangle-preview t "If non-nil, `string-rectangle' will show an-the-fly preview." + :version "25.1" :type 'boolean) (defun rectangle--string-preview () - (let ((str (minibuffer-contents))) - (when (equal str "") - (setq str (or (car-safe minibuffer-default) - (if (stringp minibuffer-default) minibuffer-default)))) - (when str (setq str (propertize str 'face 'region))) - (with-selected-window rectangle--string-preview-window - (unless (or (null rectangle--string-preview-state) - (equal str (car rectangle--string-preview-state))) - (rectangle--string-flush-preview) - (apply-on-rectangle - (lambda (startcol endcol) - (let* ((sc (move-to-column startcol)) - (start (if (<= sc startcol) (point) - (forward-char -1) - (setq sc (current-column)) - (point))) - (ec (move-to-column endcol)) - (end (point)) - (ol (make-overlay start end))) - (push ol (nthcdr 3 rectangle--string-preview-state)) - ;; FIXME: The extra spacing doesn't interact correctly with - ;; the extra spacing added by the rectangular-region-highlight. - (when (< sc startcol) - (overlay-put ol 'before-string (rectangle--space-to startcol))) - (let ((as (when (< endcol ec) - ;; (rectangle--space-to ec) - (spaces-string (- ec endcol)) - ))) - (if (= start end) - (overlay-put ol 'after-string (if as (concat str as) str)) - (overlay-put ol 'display str) - (if as (overlay-put ol 'after-string as)))))) - (nth 1 rectangle--string-preview-state) - (nth 2 rectangle--string-preview-state)))))) + (when rectangle-preview + (let ((str (minibuffer-contents))) + (when (equal str "") + (setq str (or (car-safe minibuffer-default) + (if (stringp minibuffer-default) minibuffer-default)))) + (when str (setq str (propertize str 'face 'rectangle-preview))) + (with-selected-window rectangle--string-preview-window + (unless (or (null rectangle--string-preview-state) + (equal str (car rectangle--string-preview-state))) + (rectangle--string-flush-preview) + (apply-on-rectangle + (lambda (startcol endcol) + (let* ((sc (move-to-column startcol)) + (start (if (<= sc startcol) (point) + (forward-char -1) + (setq sc (current-column)) + (point))) + (ec (move-to-column endcol)) + (end (point)) + (ol (make-overlay start end))) + (push ol (nthcdr 3 rectangle--string-preview-state)) + ;; FIXME: The extra spacing doesn't interact correctly with + ;; the extra spacing added by the rectangular-region-highlight. + (when (< sc startcol) + (overlay-put ol 'before-string (rectangle--space-to startcol))) + (let ((as (when (< endcol ec) + ;; (rectangle--space-to ec) + (spaces-string (- ec endcol)) + ))) + (if (= start end) + (overlay-put ol 'after-string (if as (concat str as) str)) + (overlay-put ol 'display str) + (if as (overlay-put ol 'after-string as)))))) + (nth 1 rectangle--string-preview-state) + (nth 2 rectangle--string-preview-state))))))) ;; FIXME: Should this be turned into inhibit-region-highlight and made to apply ;; to non-rectangular regions as well? @@ -459,10 +476,15 @@ Called from a program, takes three args; START, END and STRING." #'rectangle--string-erase-preview nil t) (add-hook 'post-command-hook #'rectangle--string-preview nil t)) - (read-string (format "String rectangle (default %s): " - (or (car string-rectangle-history) "")) - nil 'string-rectangle-history + (read-string (format "String rectangle (default %s): " + (or (car string-rectangle-history) "")) + nil 'string-rectangle-history (car string-rectangle-history))))))) + ;; If we undo this change, we want to have the point back where we + ;; are now, and not after the first line in the rectangle (which is + ;; the first line to be changed by the following command). + (unless (eq buffer-undo-list t) + (push (point) buffer-undo-list)) (goto-char (apply-on-rectangle 'string-rectangle-line start end string t))) @@ -562,6 +584,8 @@ with a prefix argument, prompt for START-AT and FORMAT." #'rectangle--unhighlight-for-redisplay) (add-function :around region-extract-function #'rectangle--extract-region) +(add-function :around region-insert-function + #'rectangle--insert-region) (defvar rectangle-mark-mode-map (let ((map (make-sparse-keymap))) @@ -680,8 +704,12 @@ Ignores `line-move-visual'." (defun rectangle--extract-region (orig &optional delete) - (if (not rectangle-mark-mode) - (funcall orig delete) + (cond + ((not rectangle-mark-mode) + (funcall orig delete)) + ((eq delete 'bounds) + (extract-rectangle-bounds (region-beginning) (region-end))) + (t (let* ((strs (funcall (if delete #'delete-extract-rectangle #'extract-rectangle) @@ -695,7 +723,14 @@ Ignores `line-move-visual'." (put-text-property 0 (length str) 'yank-handler `(rectangle--insert-for-yank ,strs t) str) - str)))) + str))))) + +(defun rectangle--insert-region (orig strings) + (cond + ((not rectangle-mark-mode) + (funcall orig strings)) + (t + (funcall #'insert-rectangle strings)))) (defun rectangle--insert-for-yank (strs) (push (point) buffer-undo-list)