[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 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 2, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

(provide 'cua-gmrk)

(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))

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