;;; cua-rect.el --- CUA unified rectangle support
-;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1997-2011 Free Software Foundation, Inc.
;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience CUA
+;; Package: cua-base
;; This file is part of GNU Emacs.
(move-to-column mc)
(set-mark (point))
(goto-char pp)
- ;; Move cursor inside rectangle, except if char at rigth edge is a tab.
+ ;; Move cursor inside rectangle, except if char at right edge is a tab.
(if (and (if (cua--rectangle-right-side)
(and (= (move-to-column pc) (- pc tab-width))
(not (eolp)))
(let ((lines 0))
(if (not (cua--rectangle-virtual-edges))
(cua--rectangle-operation nil nil t 2 t
- '(lambda (s e l r v)
- (setq lines (1+ lines))
- (if (and (> e s) (<= e (point-max)))
- (delete-region s e))))
+ (lambda (s e l r v)
+ (setq lines (1+ lines))
+ (if (and (> e s) (<= e (point-max)))
+ (delete-region s e))))
(cua--rectangle-operation nil 1 t nil t
- '(lambda (s e l r v)
+ (lambda (s e l r v)
(setq lines (1+ lines))
(when (and (> e s) (<= e (point-max)))
(delete-region s e)))))
(let (rect)
(if (not (cua--rectangle-virtual-edges))
(cua--rectangle-operation nil nil nil nil nil ; do not tabify
- '(lambda (s e l r)
- (setq rect (cons (filter-buffer-substring s e nil t) rect))))
+ (lambda (s e l r)
+ (setq rect (cons (cua--filter-buffer-noprops s e) rect))))
(cua--rectangle-operation nil 1 nil nil nil ; do not tabify
- '(lambda (s e l r v)
+ (lambda (s e l r v)
(let ((copy t) (bs 0) (as 0) row)
(if (= s e) (setq e (1+ e)))
(goto-char s)
(setq as (- r (max (current-column) l))
e (point)))
(setq row (if (and copy (> e s))
- (filter-buffer-substring s e nil t)
+ (cua--filter-buffer-noprops s e)
""))
(when (> bs 0)
(setq row (concat (make-string bs ?\s) row)))
(when (/= left right)
(sit-for 0) ; make window top/bottom reliable
(cua--rectangle-operation nil t nil nil nil ; do not tabify
- '(lambda (s e l r v)
+ (lambda (s e l r v)
(let ((rface (if v 'cua-rectangle 'cua-rectangle-noselect))
overlay bs ms as)
(when (cua--rectangle-virtual-edges)
(pad (cua--rectangle-virtual-edges))
indent)
(cua--rectangle-operation (if clear 'clear 'corners) nil t pad nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(move-to-column col pad)
(if (and (eolp)
(< (current-column) col))
(move-to-column col t))
(cond
(to-col (indent-to to-col))
- (ch (insert ch))
+ ((and ch (not (eq ch ?\t))) (insert ch))
(t (tab-to-tab-stop)))
(if (cua--rectangle-right-side t)
(cua--rectangle-insert-col (current-column))
(setq indent (- (current-column) l))))
- '(lambda (l r)
+ (lambda (l r)
(when (and indent (> indent 0))
(aset cua--rectangle 2 (+ l indent))
(aset cua--rectangle 3 (+ r indent -1)))))))
but instead winds up to the right of the rectangle."
(interactive)
(cua--rectangle-operation 'corners nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(skip-chars-forward " \t")
(let ((ws (- (current-column) l))
(p (point)))
With prefix arg, also delete whitespace to the left of that column."
(interactive "P")
(cua--rectangle-operation 'clear nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(when arg
(skip-syntax-backward " " (line-beginning-position))
(setq s (point)))
The text previously in the rectangle is overwritten by the blanks."
(interactive)
(cua--rectangle-operation 'keep nil nil 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(goto-char e)
(skip-syntax-forward " " (line-end-position))
(setq e (point))
(interactive)
(let (x)
(cua--rectangle-operation 'clear nil t t nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(let ((b (line-beginning-position)))
(skip-syntax-backward "^ " b)
(skip-syntax-backward " " b)
(skip-syntax-forward " " (line-end-position))
(delete-region s (point))
(indent-to l))
- '(lambda (l r)
+ (lambda (l r)
(move-to-column l)
;; (setq cua-save-point (point))
))))
The length of STRING need not be the same as the rectangle width."
(interactive "sString rectangle: ")
(cua--rectangle-operation 'keep nil t t nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(delete-region s e)
(skip-chars-forward " \t")
(let ((ws (- (current-column) l)))
(insert string)
(indent-to (+ (current-column) ws))))
(unless (cua--rectangle-restriction)
- '(lambda (l r)
+ (lambda (l r)
(cua--rectangle-right (max l (+ l (length string) -1)))))))
(defun cua-fill-char-rectangle (character)
"Replace CUA rectangle contents with CHARACTER."
(interactive "cFill rectangle with character: ")
(cua--rectangle-operation 'clear nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(delete-region s e)
(move-to-column l t)
(insert-char character (- r l)))))
(if buffer-read-only
(message "Cannot replace in read-only buffer")
(cua--rectangle-operation 'keep nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(if (re-search-forward regexp e t)
(replace-match newtext nil nil))))))
"Increment each line of CUA rectangle by prefix amount."
(interactive "p")
(cua--rectangle-operation 'keep nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(cond
((re-search-forward "0x\\([0-9a-fA-F]+\\)" e t)
- (let* ((txt (filter-buffer-substring (match-beginning 1) (match-end 1) nil t))
+ (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
(n (string-to-number txt 16))
(fmt (format "0x%%0%dx" (length txt))))
(replace-match (format fmt (+ n increment)))))
((re-search-forward "\\( *-?[0-9]+\\)" e t)
- (let* ((txt (filter-buffer-substring (match-beginning 1) (match-end 1) nil t))
+ (let* ((txt (cua--filter-buffer-noprops (match-beginning 1) (match-end 1)))
(prefix (if (= (aref txt 0) ?0) "0" ""))
(n (string-to-number txt 10))
(fmt (format "%%%s%dd" prefix (length txt))))
(setq format cua--rectangle-seq-format)
(setq cua--rectangle-seq-format format))
(cua--rectangle-operation 'clear nil t 1 nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(delete-region s e)
(insert (format format first))
(setq first (+ first incr)))))
(defmacro cua--convert-rectangle-as (command tabify)
`(cua--rectangle-operation 'clear nil nil nil ,tabify
- '(lambda (s e l r)
+ (lambda (s e l r)
(,command s e))))
(defun cua-upcase-rectangle ()
(- (cua--rectangle-right) (cua--rectangle-left) -1)))
(r (or setup-fct (cua--extract-rectangle)))
y z (tr 0))
- (save-excursion
- (set-buffer auxbuf)
+ (with-current-buffer auxbuf
(erase-buffer)
(if setup-fct
(funcall setup-fct)
(if cua--debug
(print z auxbuf))
(cua--rectangle-operation nil nil t pad nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(let (cc)
(goto-char e)
(skip-chars-forward " \t")
nil nil nil nil)))
(cua--rectangle-aux-replace width t t t 1
'cua--left-fill-rectangle
- '(lambda () (insert text))))
+ (lambda () (insert text))))
(defun cua-refill-rectangle (width)
"Fill contents of current rectagle.
nil nil nil
'shell-command-history)))
(cua--rectangle-aux-replace -1 t t replace 1
- '(lambda (s e)
+ (lambda (s e)
(shell-command-on-region s e command
replace replace nil))))
"Remove the first line of the rectangle and scroll remaining lines up."
(interactive)
(cua--rectangle-aux-replace 0 t t t t
- '(lambda (s e)
+ (lambda (s e)
(if (= (forward-line 1) 0)
(delete-region s (point))))))
The remaining lines are scrolled down, losing the last line."
(interactive)
(cua--rectangle-aux-replace 0 t t t t
- '(lambda (s e)
+ (lambda (s e)
(goto-char s)
(insert "\n"))))
(pad (cua--rectangle-virtual-edges))
indent)
(cua--rectangle-operation 'corners nil t pad nil
- '(lambda (s e l r)
+ (lambda (s e l r)
(move-to-column
(if (cua--rectangle-right-side t)
(max (1+ r) col) l)
pad)
(if (bolp)
nil
- (delete-backward-char 1)
+ (delete-char -1)
(if (cua--rectangle-right-side t)
(cua--rectangle-insert-col (current-column))
(setq indent (- l (current-column))))))
- '(lambda (l r)
+ (lambda (l r)
(when (and indent (> indent 0))
(aset cua--rectangle 2 (- l indent))
(aset cua--rectangle 3 (- r indent 1)))))))
(define-key cua--rectangle-keymap [remap beginning-of-buffer] 'cua-resize-rectangle-top)
(define-key cua--rectangle-keymap [remap scroll-down] 'cua-resize-rectangle-page-up)
(define-key cua--rectangle-keymap [remap scroll-up] 'cua-resize-rectangle-page-down)
+ (define-key cua--rectangle-keymap [remap scroll-down-command] 'cua-resize-rectangle-page-up)
+ (define-key cua--rectangle-keymap [remap scroll-up-command] 'cua-resize-rectangle-page-down)
(define-key cua--rectangle-keymap [remap delete-backward-char] 'cua-delete-char-rectangle)
(define-key cua--rectangle-keymap [remap backward-delete-char] 'cua-delete-char-rectangle)
(provide 'cua-rect)
-;; arch-tag: b730df53-17b9-4a89-bd63-4a71ec196731
;;; cua-rect.el ends here