--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/utils/atomic-extents.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,109 @@
+;;; atomic-extents.el --- treat regions of text as a single object
+
+;; Copyright (C) 1993 Free Software Foundation, Inc.
+;; Created: 21-Dec-93, Chuck Thompson <cthomp@cs.uiuc.edu>
+;; Keywords: extensions
+;; Changed: 08-Aug-94, Heiko Muenkel <muenkel@tnt.uni-hannover.de>
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Point is not allowed to fall inside of an atomic extent.  This has
+;;; the effect of making all text covered by an atomic extent be
+;;; treated as a single object.  Normally point will be adjusted to an
+;;; end of an atomic extent in the direction of motion.  If point
+;;; appears inside of an atomic extent (via goto-char for example),
+;;; point will be adjusted to the side closest to the entry point.
+
+;;; Synched up with: Not in FSF.
+
+;;; To make an extent atomic use the command:
+;;;	(set-extent-property #<extent obj> 'atomic t)
+
+;;; Known bug: the atomic property is not detected when sweeping
+;;; regions with the mouse until after the mouse button is released.
+;;; The release point will then be treated as if it had been reached
+;;; using 'goto-char.
+
+;;; atomic-extent-goto-char-p is defined in editfns.c
+
+(provide 'atomic-extents)
+
+(defvar atomic-extent-old-point nil
+  "The value of point when pre-command-hook is called.
+Used to determine the direction of motion.")
+
+(defun atomic-extent-pre-hook ()
+  (setq atomic-extent-old-point (point))
+  (setq atomic-extent-goto-char-p nil))
+
+(defun atomic-extent-post-hook ()
+  (let ((extent (extent-at (point) nil 'atomic)))
+    (if extent
+	(let ((begin (extent-start-position extent))
+	      (end (extent-end-position extent))
+	      (pos (point))
+	      (region-set (and (point) (mark))))
+	  (if (eq this-command
+		  'x-set-point-and-insert-selection)
+	      (delete-region (region-beginning) (region-end)))
+	  (if (/= pos begin)
+	      (if atomic-extent-goto-char-p
+		  (progn
+		    (if (> (- pos begin) (- end pos))
+			(goto-char end)
+		      (goto-char begin)))
+		(if (> pos atomic-extent-old-point)
+		    (goto-char end)
+		  (goto-char begin))))
+	  (if (and region-set (/= pos begin))
+	      (progn
+		(run-hooks 'zmacs-update-region-hook)
+		(x-store-cutbuffer (buffer-substring (region-beginning)
+						     (region-end)))
+		)))))
+  (if (mark)
+      (progn
+	(exchange-point-and-mark t)
+	(let ((extent (extent-at (point) nil 'atomic)))
+	  (if extent
+	      (let ((begin (extent-start-position extent))
+		    (end (extent-end-position extent))
+		    (pos (point))
+		    (region-set (and (point) (mark))))
+		(if (/= pos begin)
+		    (if atomic-extent-goto-char-p
+			(progn
+			  (if (> (- pos begin) (- end pos))
+			      (goto-char end)
+			    (goto-char begin)))
+		      (if (> pos atomic-extent-old-point)
+			  (goto-char end)
+			(goto-char begin))))
+		(if (and region-set (/= pos begin))
+		    (progn
+		      (run-hooks 'zmacs-update-region-hook)
+		      (x-store-cutbuffer (buffer-substring (region-beginning)
+							   (region-end)))
+		(message "%d, %d" (region-beginning) (region-end))
+		      )))))
+	(exchange-point-and-mark t)))
+  )
+
+(add-hook 'pre-command-hook 'atomic-extent-pre-hook)
+(add-hook 'post-command-hook 'atomic-extent-post-hook)
+
+;;; atomic-extents.el ends here