[bpt/emacs.git] / lisp / emulation / cua-gmrk.el

;;; cua-gmrk.el --- CUA unified global mark support

;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

;; Author: Kim F. Storm <storm@cua.dk>
;; Keywords: keyboard emulations convenience cua mark

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cua-base)
  (require 'cua-rect)
  )

;;; Global Marker

;; Non-nil when global marker is active.
(defvar cua--global-mark-active nil)

;; Global mark position marker.
(defvar cua--global-mark-marker nil)

;; Overlay for global mark position.
(defvar cua--global-mark-overlay nil)

;; Initialize global mark things once...
(defvar cua--global-mark-initialized nil)

;; Saved configured blink-cursor-interval
(defvar cua--orig-blink-cursor-interval nil)

(defun cua--deactivate-global-mark (&optional msg)
  (when cua--global-mark-overlay
    (delete-overlay cua--global-mark-overlay)
    (setq cua--global-mark-overlay nil))
  (if (markerp cua--global-mark-marker)
      (move-marker cua--global-mark-marker nil))
  (if cua--orig-blink-cursor-interval
      (setq blink-cursor-interval cua--orig-blink-cursor-interval
	    cua--orig-blink-cursor-interval nil))
  (setq cua--global-mark-active nil)
  (if msg
      (message "Global Mark Cleared")))

(defun cua--activate-global-mark (&optional msg)
  (if (not (markerp cua--global-mark-marker))
      (setq cua--global-mark-marker (make-marker)))
  (when (eobp)
    (insert " ")
    (backward-char 1))
  (move-marker cua--global-mark-marker (point))
  (if (overlayp cua--global-mark-overlay)
      (move-overlay cua--global-mark-overlay (point) (1+ (point)))
    (setq cua--global-mark-overlay
	  (make-overlay (point) (1+ (point))))
    (overlay-put cua--global-mark-overlay 'face 'cua-global-mark))
  (if (and cua-global-mark-blink-cursor-interval
	   (not cua--orig-blink-cursor-interval))
      (setq cua--orig-blink-cursor-interval blink-cursor-interval
	    blink-cursor-interval cua-global-mark-blink-cursor-interval))
  (setq cua--global-mark-active t)
  (if msg
      (message "Global Mark Set")))

(defun cua--global-mark-active ()
  (if cua--global-mark-active
      (or (and (markerp cua--global-mark-marker)
	       (marker-buffer cua--global-mark-marker))
	  (and (cua--deactivate-global-mark nil)
	       nil))))

(defun cua-toggle-global-mark (stay)
  "Set or cancel the global marker.
When the global marker is set, CUA cut and copy commands will automatically
insert the deleted or copied text before the global marker, even when the
global marker is in another buffer.
If the global marker isn't set, set the global marker at point in the current
buffer.  Otherwise jump to the global marker position and cancel it.
With prefix argument, don't jump to global mark when cancelling it."
  (interactive "P")
  (unless cua--global-mark-initialized
    (cua--init-global-mark))
  (if (not (cua--global-mark-active))
      (if (not buffer-read-only)
	  (cua--activate-global-mark t)
	(ding)
	(message "Cannot set global mark in read-only buffer"))
    (when (not stay)
      (pop-to-buffer (marker-buffer cua--global-mark-marker))
      (goto-char cua--global-mark-marker))
    (cua--deactivate-global-mark t)))

(defun cua--insert-at-global-mark (str &optional msg)
  ;; Insert string at global marker and move marker
  (save-excursion
    (set-buffer (marker-buffer cua--global-mark-marker))
    (goto-char (marker-position cua--global-mark-marker))
    (insert-for-yank str)
    (cua--activate-global-mark))
  (if msg
      (message "%s %d to global mark in %s:%d" msg
	       (length str)
	       (buffer-name (marker-buffer cua--global-mark-marker))
	       (marker-position cua--global-mark-marker))))

(defun cua--delete-at-global-mark (arg &optional msg)
  ;; Delete chars at global marker
  (save-excursion
    (set-buffer (marker-buffer cua--global-mark-marker))
    (goto-char (marker-position cua--global-mark-marker))
    (delete-char arg))
  (if msg
      (message "%s %d chars at global mark in %s:%d" msg arg
	       (buffer-name (marker-buffer cua--global-mark-marker))
	       (marker-position cua--global-mark-marker))))

(defun cua-copy-region-to-global-mark (start end)
  "Copy region to global mark buffer/position."
  (interactive "r")
  (if (cua--global-mark-active)
      (let ((src-buf (current-buffer)))
	(save-excursion
	  (if (equal (marker-buffer cua--global-mark-marker) src-buf)
	      (let ((text (filter-buffer-substring start end nil t)))
		(goto-char (marker-position cua--global-mark-marker))
		(insert text))
	    (set-buffer (marker-buffer cua--global-mark-marker))
	    (goto-char (marker-position cua--global-mark-marker))
	    (insert-buffer-substring-as-yank src-buf start end))
	  (cua--activate-global-mark)
	  (message "Copied %d to global mark in %s:%d"
		   (abs (- end start))
		   (buffer-name (marker-buffer cua--global-mark-marker))
		   (marker-position cua--global-mark-marker))))
    (cua--deactivate-global-mark)
    (message "No Global Mark")))

(defun cua-cut-region-to-global-mark (start end)
  "Move region to global buffer/position."
  (interactive "r")
  (if (cua--global-mark-active)
      (let ((src-buf (current-buffer)))
	(save-excursion
	  (if (equal (marker-buffer cua--global-mark-marker) src-buf)
	      (if (and (< start (marker-position cua--global-mark-marker))
		       (< (marker-position cua--global-mark-marker) end))
		  (message "Can't move region into itself")
		(let ((text (filter-buffer-substring start end nil t))
		      (p1 (copy-marker start))
		      (p2 (copy-marker end)))
		  (goto-char (marker-position cua--global-mark-marker))
		  (insert text)
		  (cua--activate-global-mark)
		  (delete-region (marker-position p1) (marker-position p2))
		  (move-marker p1 nil)
		  (move-marker p2 nil)))
	    (set-buffer (marker-buffer cua--global-mark-marker))
	    (goto-char (marker-position cua--global-mark-marker))
	    (insert-buffer-substring src-buf start end)
	    (message "Moved %d to global mark in %s:%d"
		     (abs (- end start))
		     (buffer-name (marker-buffer cua--global-mark-marker))
		     (marker-position cua--global-mark-marker))
	    (cua--activate-global-mark)
	    (set-buffer src-buf)
	    (delete-region start end))))
    (cua--deactivate-global-mark)
    (message "No Global Mark")))

(defun cua--copy-rectangle-to-global-mark (as-text)
  ;; Copy rectangle to global mark buffer/position.
  (if (cua--global-mark-active)
      (let ((src-buf (current-buffer))
	    (text (cua--extract-rectangle)))
	(save-excursion
	  (set-buffer (marker-buffer cua--global-mark-marker))
	  (goto-char (marker-position cua--global-mark-marker))
	  (if as-text
	      (while text
		(insert-for-yank (car text))
		(if (setq text (cdr text))
		    (insert "\n")))
	    (cua--insert-rectangle text 'auto))
	  (cua--activate-global-mark)
	  (message "Copied rectangle to global mark in %s:%d"
		   (buffer-name (marker-buffer cua--global-mark-marker))
		   (marker-position cua--global-mark-marker))))
    (cua--deactivate-global-mark)
    (message "No Global Mark")))

(defun cua--cut-rectangle-to-global-mark (as-text)
  ;; Move rectangle to global buffer/position.
  (if (cua--global-mark-active)
      (let ((src-buf (current-buffer)))
	(save-excursion
	  (if (equal (marker-buffer cua--global-mark-marker) src-buf)
	      (let ((olist (overlays-at (marker-position cua--global-mark-marker)))
		    in-rect)
		(while olist
		  (if (eq (overlay-get (car olist) 'face) 'cua-rectangle)
		      (setq in-rect t olist nil)
		    (setq olist (cdr olist))))
		(if in-rect
		    (message "Can't move rectangle into itself")
		  (let ((text (cua--extract-rectangle)))
		    (cua--delete-rectangle)
		    (goto-char (marker-position cua--global-mark-marker))
		    (if as-text
			(while text
			  (insert-for-yank (car text))
			  (if (setq text (cdr text))
			      (insert "\n")))
		      (cua--insert-rectangle text 'auto))
		    (cua--activate-global-mark))))
	    (let ((text (cua--extract-rectangle)))
	      (cua--delete-rectangle)
	      (set-buffer (marker-buffer cua--global-mark-marker))
	      (goto-char (marker-position cua--global-mark-marker))
	      (cua--insert-rectangle text 'auto))
	    (message "Moved rectangle to global mark in %s:%d"
		     (buffer-name (marker-buffer cua--global-mark-marker))
		     (marker-position cua--global-mark-marker))
	    (cua--activate-global-mark))))
    (cua--deactivate-global-mark)
    (message "No Global Mark")))

(defun cua-copy-to-global-mark ()
  "Copy active region/rectangle to global mark buffer/position."
  (interactive)
  (setq cua--last-killed-rectangle nil)
  (if cua--rectangle
      (cua--copy-rectangle-to-global-mark nil)
    (let ((start (mark)) (end (point)))
      (or (<= start end)
	  (setq start (prog1 end (setq end start))))
      (cua-copy-region-to-global-mark start end))))

(defun cua-copy-next-to-global-mark (n)
  "Copy the following N characters in buffer to global mark buffer/position."
  (interactive "p")
  (setq cua--last-killed-rectangle nil)
  (or (eobp)
      (let ((p (point)))
	(goto-char (+ p n))
	(cua-copy-region-to-global-mark p (point)))))

(defun cua-cut-to-global-mark ()
  "Move active region/rectangle to global mark buffer/position."
  (interactive)
  (if buffer-read-only
      (cua-copy-to-global-mark)
    (setq cua--last-killed-rectangle nil)
    (if cua--rectangle
	(cua--cut-rectangle-to-global-mark nil)
      (let ((start (mark)) (end (point)))
	(or (<= start end)
	    (setq start (prog1 end (setq end start))))
	(cua-cut-region-to-global-mark start end)))))

(defun cua-cut-next-to-global-mark (n)
  "Move the following N characters in buffer to global mark buffer/position."
  (interactive "p")
  (setq cua--last-killed-rectangle nil)
  (or (eobp)
      (let ((p (point)))
	(goto-char (+ p n))
	(cua-cut-region-to-global-mark p (point)))))

(defun cua-delete-char-at-global-mark (arg)
  "Delete character following the global mark position."
  (interactive "p")
  (cua--delete-at-global-mark arg "Deleted"))

(defun cua-delete-backward-char-at-global-mark (arg)
  "Delete character before the global mark position."
  (interactive "p")
  (cua--delete-at-global-mark (- arg) "Deleted backward"))

(defun cua-insert-char-at-global-mark ()
  "Insert the character you type at the global mark position."
  (interactive)
  (cua--insert-at-global-mark (char-to-string (aref (this-single-command-keys) 0)) "Inserted"))

(defun cua-insert-newline-at-global-mark ()
  "Insert a newline at the global mark position."
  (interactive)
  (cua--insert-at-global-mark "\n"))

(defun cua-indent-to-global-mark-column ()
  "Indent current line or rectangle to global mark column."
  (interactive "*")
  (if (cua--global-mark-active)
      (let (col)
	(save-excursion
	  (set-buffer (marker-buffer cua--global-mark-marker))
	  (goto-char (marker-position cua--global-mark-marker))
	  (setq col (current-column)))
	(if cua--rectangle
	    (cua--indent-rectangle nil col t)
	  (indent-to col))
	(if (eq (current-buffer) (marker-buffer cua--global-mark-marker))
	    (save-excursion
	      (goto-char (marker-position cua--global-mark-marker))
	      (move-to-column col)
	      (move-marker cua--global-mark-marker (point))
	      (move-overlay cua--global-mark-overlay (point) (1+ (point))))))))


(defun cua-cancel-global-mark ()
  "Cancel the global mark."
  (interactive)
  (if mark-active
      (cua-cancel)
    (if (cua--global-mark-active)
	(cua--deactivate-global-mark t)))
  (cua--fallback))

;;; Post-command hook for global mark.

(defun cua--global-mark-post-command ()
  (when (and (cua--global-mark-active) ;; Updates cua--global-mark-active variable
	     cua-global-mark-keep-visible)
    ;; keep global mark position visible
    (sit-for 0)
    (if (or (not (eq (current-buffer) (marker-buffer cua--global-mark-marker)))
	    (not (pos-visible-in-window-p (marker-position cua--global-mark-marker))))
	(let ((w (selected-window)) (p (point)) h)
	  ;; The following code is an attempt to keep the global mark visible in
	  ;; other window -- but it doesn't work.
	  (switch-to-buffer-other-window (marker-buffer cua--global-mark-marker) t)
	  (goto-char (marker-position cua--global-mark-marker))
	  (if (not (pos-visible-in-window-p (marker-position cua--global-mark-marker)))
	      (recenter (if (> (setq h (- (window-height) 4)) 1) h '(4))))
	  (select-window w)
	  (goto-char p)))))

;;; Initialization

(defun cua--init-global-mark ()
  (define-key cua--global-mark-keymap [remap copy-region-as-kill]	'cua-copy-to-global-mark)
  (define-key cua--global-mark-keymap [remap kill-ring-save]		'cua-copy-to-global-mark)
  (define-key cua--global-mark-keymap [remap kill-region]		'cua-cut-to-global-mark)
  (define-key cua--global-mark-keymap [remap yank]			'cua-copy-next-to-global-mark)

  (define-key cua--global-mark-keymap [remap keyboard-escape-quit]	'cua-cancel-global-mark)
  (define-key cua--global-mark-keymap [remap keyboard-quit]		'cua-cancel-global-mark)

  (define-key cua--global-mark-keymap [(control ?d)]			'cua-cut-next-to-global-mark)
  (define-key cua--global-mark-keymap [remap delete-backward-char]	'cua-delete-backward-char-at-global-mark)
  (define-key cua--global-mark-keymap [remap backward-delete-char]	'cua-delete-backward-char-at-global-mark)
  (define-key cua--global-mark-keymap [remap backward-delete-char-untabify] 'cua-delete-backward-char-at-global-mark)
  (define-key cua--global-mark-keymap [remap self-insert-command]	'cua-insert-char-at-global-mark)
  (define-key cua--global-mark-keymap [remap self-insert-iso]		'cua-insert-char-at-global-mark)

  ;; Catch self-inserting characters which are "stolen" by other modes
  (define-key cua--global-mark-keymap [t]
    '(menu-item "sic" cua-insert-char-at-global-mark :filter cua--self-insert-char-p))

  (define-key cua--global-mark-keymap [remap newline]			'cua-insert-newline-at-global-mark)
  (define-key cua--global-mark-keymap [remap newline-and-indent]	'cua-insert-newline-at-global-mark)
  (define-key cua--global-mark-keymap "\r"				'cua-insert-newline-at-global-mark)

  (define-key cua--global-mark-keymap "\t"				'cua-indent-to-global-mark-column)

  (setq cua--global-mark-initialized t))

(provide 'cua-gmrk)

;; arch-tag: 553d8076-a91d-48ae-825d-6cb962a5f67f
;;; cua-gmrk.el ends here
Commit	Line	Data
72cc582e KS	1	;;; cua-gmrk.el --- CUA unified global mark support
72cc582e KS	2
5fd6d89f	3	;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
ae940284	4	;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
72cc582e KS	5
	6	;; Author: Kim F. Storm <storm@cua.dk>
	7	;; Keywords: keyboard emulations convenience cua mark
	8
	9	;; This file is part of GNU Emacs.
	10
ed0f493f	11	;; GNU Emacs is free software: you can redistribute it and/or modify
72cc582e	12	;; it under the terms of the GNU General Public License as published by
ed0f493f GM	13	;; the Free Software Foundation, either version 3 of the License, or
ed0f493f GM	14	;; (at your option) any later version.
72cc582e KS	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
ed0f493f	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
72cc582e	23
30764597 PJ	24	;;; Commentary:
	25
	26	;;; Code:
72cc582e	27
72cc582e KS	28	(eval-when-compile
	29	(require 'cua-base)
	30	(require 'cua-rect)
	31	)
	32
a1506d29	33	;;; Global Marker
72cc582e KS	34
	35	;; Non-nil when global marker is active.
	36	(defvar cua--global-mark-active nil)
	37
	38	;; Global mark position marker.
	39	(defvar cua--global-mark-marker nil)
	40
	41	;; Overlay for global mark position.
	42	(defvar cua--global-mark-overlay nil)
	43
	44	;; Initialize global mark things once...
	45	(defvar cua--global-mark-initialized nil)
	46
	47	;; Saved configured blink-cursor-interval
	48	(defvar cua--orig-blink-cursor-interval nil)
	49
	50	(defun cua--deactivate-global-mark (&optional msg)
	51	(when cua--global-mark-overlay
	52	(delete-overlay cua--global-mark-overlay)
	53	(setq cua--global-mark-overlay nil))
	54	(if (markerp cua--global-mark-marker)
	55	(move-marker cua--global-mark-marker nil))
	56	(if cua--orig-blink-cursor-interval
	57	(setq blink-cursor-interval cua--orig-blink-cursor-interval
	58	cua--orig-blink-cursor-interval nil))
	59	(setq cua--global-mark-active nil)
	60	(if msg
	61	(message "Global Mark Cleared")))
	62
	63	(defun cua--activate-global-mark (&optional msg)
	64	(if (not (markerp cua--global-mark-marker))
	65	(setq cua--global-mark-marker (make-marker)))
	66	(when (eobp)
	67	(insert " ")
	68	(backward-char 1))
	69	(move-marker cua--global-mark-marker (point))
	70	(if (overlayp cua--global-mark-overlay)
	71	(move-overlay cua--global-mark-overlay (point) (1+ (point)))
a1506d29	72	(setq cua--global-mark-overlay
72cc582e	73	(make-overlay (point) (1+ (point))))
1e98d199	74	(overlay-put cua--global-mark-overlay 'face 'cua-global-mark))
72cc582e KS	75	(if (and cua-global-mark-blink-cursor-interval
72cc582e KS	76	(not cua--orig-blink-cursor-interval))
a1506d29	77	(setq cua--orig-blink-cursor-interval blink-cursor-interval
72cc582e KS	78	blink-cursor-interval cua-global-mark-blink-cursor-interval))
	79	(setq cua--global-mark-active t)
	80	(if msg
	81	(message "Global Mark Set")))
	82
	83	(defun cua--global-mark-active ()
	84	(if cua--global-mark-active
	85	(or (and (markerp cua--global-mark-marker)
	86	(marker-buffer cua--global-mark-marker))
	87	(and (cua--deactivate-global-mark nil)
	88	nil))))
	89
	90	(defun cua-toggle-global-mark (stay)
	91	"Set or cancel the global marker.
	92	When the global marker is set, CUA cut and copy commands will automatically
	93	insert the deleted or copied text before the global marker, even when the
	94	global marker is in another buffer.
	95	If the global marker isn't set, set the global marker at point in the current
c23eed1b	96	buffer. Otherwise jump to the global marker position and cancel it.
72cc582e KS	97	With prefix argument, don't jump to global mark when cancelling it."
	98	(interactive "P")
	99	(unless cua--global-mark-initialized
	100	(cua--init-global-mark))
	101	(if (not (cua--global-mark-active))
	102	(if (not buffer-read-only)
	103	(cua--activate-global-mark t)
	104	(ding)
c23eed1b	105	(message "Cannot set global mark in read-only buffer"))
72cc582e KS	106	(when (not stay)
	107	(pop-to-buffer (marker-buffer cua--global-mark-marker))
	108	(goto-char cua--global-mark-marker))
	109	(cua--deactivate-global-mark t)))
	110
	111	(defun cua--insert-at-global-mark (str &optional msg)
	112	;; Insert string at global marker and move marker
	113	(save-excursion
	114	(set-buffer (marker-buffer cua--global-mark-marker))
	115	(goto-char (marker-position cua--global-mark-marker))
	116	(insert-for-yank str)
	117	(cua--activate-global-mark))
	118	(if msg
	119	(message "%s %d to global mark in %s:%d" msg
	120	(length str)
	121	(buffer-name (marker-buffer cua--global-mark-marker))
	122	(marker-position cua--global-mark-marker))))
	123
	124	(defun cua--delete-at-global-mark (arg &optional msg)
	125	;; Delete chars at global marker
	126	(save-excursion
	127	(set-buffer (marker-buffer cua--global-mark-marker))
	128	(goto-char (marker-position cua--global-mark-marker))
	129	(delete-char arg))
	130	(if msg
	131	(message "%s %d chars at global mark in %s:%d" msg arg
	132	(buffer-name (marker-buffer cua--global-mark-marker))
	133	(marker-position cua--global-mark-marker))))
	134
	135	(defun cua-copy-region-to-global-mark (start end)
	136	"Copy region to global mark buffer/position."
	137	(interactive "r")
	138	(if (cua--global-mark-active)
	139	(let ((src-buf (current-buffer)))
	140	(save-excursion
	141	(if (equal (marker-buffer cua--global-mark-marker) src-buf)
a4dad45a	142	(let ((text (filter-buffer-substring start end nil t)))
72cc582e KS	143	(goto-char (marker-position cua--global-mark-marker))
	144	(insert text))
	145	(set-buffer (marker-buffer cua--global-mark-marker))
	146	(goto-char (marker-position cua--global-mark-marker))
	147	(insert-buffer-substring-as-yank src-buf start end))
	148	(cua--activate-global-mark)
	149	(message "Copied %d to global mark in %s:%d"
	150	(abs (- end start))
	151	(buffer-name (marker-buffer cua--global-mark-marker))
	152	(marker-position cua--global-mark-marker))))
	153	(cua--deactivate-global-mark)
	154	(message "No Global Mark")))
	155
	156	(defun cua-cut-region-to-global-mark (start end)
	157	"Move region to global buffer/position."
	158	(interactive "r")
	159	(if (cua--global-mark-active)
	160	(let ((src-buf (current-buffer)))
	161	(save-excursion
	162	(if (equal (marker-buffer cua--global-mark-marker) src-buf)
	163	(if (and (< start (marker-position cua--global-mark-marker))
	164	(< (marker-position cua--global-mark-marker) end))
c23eed1b	165	(message "Can't move region into itself")
a4dad45a	166	(let ((text (filter-buffer-substring start end nil t))
72cc582e KS	167	(p1 (copy-marker start))
	168	(p2 (copy-marker end)))
	169	(goto-char (marker-position cua--global-mark-marker))
	170	(insert text)
	171	(cua--activate-global-mark)
	172	(delete-region (marker-position p1) (marker-position p2))
	173	(move-marker p1 nil)
	174	(move-marker p2 nil)))
	175	(set-buffer (marker-buffer cua--global-mark-marker))
	176	(goto-char (marker-position cua--global-mark-marker))
	177	(insert-buffer-substring src-buf start end)
	178	(message "Moved %d to global mark in %s:%d"
	179	(abs (- end start))
	180	(buffer-name (marker-buffer cua--global-mark-marker))
	181	(marker-position cua--global-mark-marker))
	182	(cua--activate-global-mark)
	183	(set-buffer src-buf)
	184	(delete-region start end))))
	185	(cua--deactivate-global-mark)
	186	(message "No Global Mark")))
	187
	188	(defun cua--copy-rectangle-to-global-mark (as-text)
	189	;; Copy rectangle to global mark buffer/position.
	190	(if (cua--global-mark-active)
	191	(let ((src-buf (current-buffer))
	192	(text (cua--extract-rectangle)))
	193	(save-excursion
	194	(set-buffer (marker-buffer cua--global-mark-marker))
	195	(goto-char (marker-position cua--global-mark-marker))
	196	(if as-text
	197	(while text
	198	(insert-for-yank (car text))
	199	(if (setq text (cdr text))
	200	(insert "\n")))
	201	(cua--insert-rectangle text 'auto))
	202	(cua--activate-global-mark)
	203	(message "Copied rectangle to global mark in %s:%d"
	204	(buffer-name (marker-buffer cua--global-mark-marker))
	205	(marker-position cua--global-mark-marker))))
	206	(cua--deactivate-global-mark)
	207	(message "No Global Mark")))
	208
	209	(defun cua--cut-rectangle-to-global-mark (as-text)
	210	;; Move rectangle to global buffer/position.
	211	(if (cua--global-mark-active)
	212	(let ((src-buf (current-buffer)))
	213	(save-excursion
	214	(if (equal (marker-buffer cua--global-mark-marker) src-buf)
	215	(let ((olist (overlays-at (marker-position cua--global-mark-marker)))
	216	in-rect)
	217	(while olist
1e98d199	218	(if (eq (overlay-get (car olist) 'face) 'cua-rectangle)
72cc582e KS	219	(setq in-rect t olist nil)
	220	(setq olist (cdr olist))))
	221	(if in-rect
c23eed1b	222	(message "Can't move rectangle into itself")
72cc582e KS	223	(let ((text (cua--extract-rectangle)))
	224	(cua--delete-rectangle)
	225	(goto-char (marker-position cua--global-mark-marker))
	226	(if as-text
	227	(while text
	228	(insert-for-yank (car text))
	229	(if (setq text (cdr text))
	230	(insert "\n")))
	231	(cua--insert-rectangle text 'auto))
	232	(cua--activate-global-mark))))
	233	(let ((text (cua--extract-rectangle)))
	234	(cua--delete-rectangle)
	235	(set-buffer (marker-buffer cua--global-mark-marker))
	236	(goto-char (marker-position cua--global-mark-marker))
	237	(cua--insert-rectangle text 'auto))
	238	(message "Moved rectangle to global mark in %s:%d"
	239	(buffer-name (marker-buffer cua--global-mark-marker))
	240	(marker-position cua--global-mark-marker))
	241	(cua--activate-global-mark))))
	242	(cua--deactivate-global-mark)
	243	(message "No Global Mark")))
	244
	245	(defun cua-copy-to-global-mark ()
	246	"Copy active region/rectangle to global mark buffer/position."
	247	(interactive)
	248	(setq cua--last-killed-rectangle nil)
	249	(if cua--rectangle
	250	(cua--copy-rectangle-to-global-mark nil)
	251	(let ((start (mark)) (end (point)))
	252	(or (<= start end)
	253	(setq start (prog1 end (setq end start))))
	254	(cua-copy-region-to-global-mark start end))))
	255
	256	(defun cua-copy-next-to-global-mark (n)
	257	"Copy the following N characters in buffer to global mark buffer/position."
	258	(interactive "p")
	259	(setq cua--last-killed-rectangle nil)
	260	(or (eobp)
	261	(let ((p (point)))
	262	(goto-char (+ p n))
	263	(cua-copy-region-to-global-mark p (point)))))
	264
	265	(defun cua-cut-to-global-mark ()
	266	"Move active region/rectangle to global mark buffer/position."
	267	(interactive)
	268	(if buffer-read-only
	269	(cua-copy-to-global-mark)
	270	(setq cua--last-killed-rectangle nil)
	271	(if cua--rectangle
	272	(cua--cut-rectangle-to-global-mark nil)
	273	(let ((start (mark)) (end (point)))
	274	(or (<= start end)
	275	(setq start (prog1 end (setq end start))))
	276	(cua-cut-region-to-global-mark start end)))))
	277
	278	(defun cua-cut-next-to-global-mark (n)
	279	"Move the following N characters in buffer to global mark buffer/position."
	280	(interactive "p")
	281	(setq cua--last-killed-rectangle nil)
	282	(or (eobp)
	283	(let ((p (point)))
	284	(goto-char (+ p n))
	285	(cua-cut-region-to-global-mark p (point)))))
	286
287	(defun cua-delete-char-at-global-mark (arg)
288	"Delete character following the global mark position."
289	(interactive "p")
290	(cua--delete-at-global-mark arg "Deleted"))
291
292	(defun cua-delete-backward-char-at-global-mark (arg)
293	"Delete character before the global mark position."
294	(interactive "p")
295	(cua--delete-at-global-mark (- arg) "Deleted backward"))
296
297	(defun cua-insert-char-at-global-mark ()
298	"Insert the character you type at the global mark position."
299	(interactive)
300	(cua--insert-at-global-mark (char-to-string (aref (this-single-command-keys) 0)) "Inserted"))
301
302	(defun cua-insert-newline-at-global-mark ()
303	"Insert a newline at the global mark position."
304	(interactive)
305	(cua--insert-at-global-mark "\n"))
306
307	(defun cua-indent-to-global-mark-column ()
308	"Indent current line or rectangle to global mark column."
309	(interactive "*")
310	(if (cua--global-mark-active)
311	(let (col)
312	(save-excursion
313	(set-buffer (marker-buffer cua--global-mark-marker))
314	(goto-char (marker-position cua--global-mark-marker))
315	(setq col (current-column)))
316	(if cua--rectangle
317	(cua--indent-rectangle nil col t)
318	(indent-to col))
319	(if (eq (current-buffer) (marker-buffer cua--global-mark-marker))
320	(save-excursion
321	(goto-char (marker-position cua--global-mark-marker))
322	(move-to-column col)
323	(move-marker cua--global-mark-marker (point))
324	(move-overlay cua--global-mark-overlay (point) (1+ (point))))))))
a1506d29	325
72cc582e KS	326
	327	(defun cua-cancel-global-mark ()
	328	"Cancel the global mark."
	329	(interactive)
	330	(if mark-active
	331	(cua-cancel)
	332	(if (cua--global-mark-active)
	333	(cua--deactivate-global-mark t)))
	334	(cua--fallback))
	335
	336	;;; Post-command hook for global mark.
	337
	338	(defun cua--global-mark-post-command ()
	339	(when (and (cua--global-mark-active) ;; Updates cua--global-mark-active variable
	340	cua-global-mark-keep-visible)
	341	;; keep global mark position visible
	342	(sit-for 0)
	343	(if (or (not (eq (current-buffer) (marker-buffer cua--global-mark-marker)))
	344	(not (pos-visible-in-window-p (marker-position cua--global-mark-marker))))
	345	(let ((w (selected-window)) (p (point)) h)
a1506d29	346	;; The following code is an attempt to keep the global mark visible in
72cc582e KS	347	;; other window -- but it doesn't work.
	348	(switch-to-buffer-other-window (marker-buffer cua--global-mark-marker) t)
	349	(goto-char (marker-position cua--global-mark-marker))
	350	(if (not (pos-visible-in-window-p (marker-position cua--global-mark-marker)))
	351	(recenter (if (> (setq h (- (window-height) 4)) 1) h '(4))))
	352	(select-window w)
	353	(goto-char p)))))
	354
	355	;;; Initialization
	356
	357	(defun cua--init-global-mark ()
72cc582e KS	358	(define-key cua--global-mark-keymap [remap copy-region-as-kill] 'cua-copy-to-global-mark)
	359	(define-key cua--global-mark-keymap [remap kill-ring-save] 'cua-copy-to-global-mark)
	360	(define-key cua--global-mark-keymap [remap kill-region] 'cua-cut-to-global-mark)
	361	(define-key cua--global-mark-keymap [remap yank] 'cua-copy-next-to-global-mark)
	362
	363	(define-key cua--global-mark-keymap [remap keyboard-escape-quit] 'cua-cancel-global-mark)
	364	(define-key cua--global-mark-keymap [remap keyboard-quit] 'cua-cancel-global-mark)
	365
	366	(define-key cua--global-mark-keymap [(control ?d)] 'cua-cut-next-to-global-mark)
	367	(define-key cua--global-mark-keymap [remap delete-backward-char] 'cua-delete-backward-char-at-global-mark)
	368	(define-key cua--global-mark-keymap [remap backward-delete-char] 'cua-delete-backward-char-at-global-mark)
	369	(define-key cua--global-mark-keymap [remap backward-delete-char-untabify] 'cua-delete-backward-char-at-global-mark)
	370	(define-key cua--global-mark-keymap [remap self-insert-command] 'cua-insert-char-at-global-mark)
	371	(define-key cua--global-mark-keymap [remap self-insert-iso] 'cua-insert-char-at-global-mark)
f8b38495 KS	372
	373	;; Catch self-inserting characters which are "stolen" by other modes
	374	(define-key cua--global-mark-keymap [t]
	375	'(menu-item "sic" cua-insert-char-at-global-mark :filter cua--self-insert-char-p))
	376
72cc582e KS	377	(define-key cua--global-mark-keymap [remap newline] 'cua-insert-newline-at-global-mark)
	378	(define-key cua--global-mark-keymap [remap newline-and-indent] 'cua-insert-newline-at-global-mark)
	379	(define-key cua--global-mark-keymap "\r" 'cua-insert-newline-at-global-mark)
	380
	381	(define-key cua--global-mark-keymap "\t" 'cua-indent-to-global-mark-column)
	382
	383	(setq cua--global-mark-initialized t))
	384
88a25b18 GM	385	(provide 'cua-gmrk)
88a25b18 GM	386
cbee283d	387	;; arch-tag: 553d8076-a91d-48ae-825d-6cb962a5f67f
72cc582e	388	;;; cua-gmrk.el ends here