;; Mouse support for X window system.
;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.

;; 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.

(require 'mouse)

;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
;; This is reserved for use by Hyperbole.
;;(define-key global-map '(shift button2) 'x-mouse-kill)
(define-key global-map '(control button2) 'x-set-point-and-move-selection)

(setq mouse-yank-function 'x-yank-function)

(defvar inhibit-help-echo nil
  "Inhibits display of `help-echo' extent properties in the minibuffer.")

(defun x-mouse-kill (event)
  "Kill the text between the point and mouse and copy it to the clipboard and
to the cut buffer"
  (interactive "@e")
  (let ((old-point (point)))
    (mouse-set-point event)
    (let ((s (buffer-substring old-point (point))))
      (x-own-clipboard s)
      (x-store-cutbuffer s))
    (kill-region old-point (point))))

(defun x-yank-function ()
  "Insert the current X selection or, if there is none, insert the X cutbuffer.
A mark is pushed, so that the inserted text lies between point and mark."
  (push-mark)
  (if (region-active-p)
       (insert (extent-string zmacs-region-extent))
    (x-insert-selection t)))

(defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
  "Insert the current selection into buffer at point."
  (interactive "P")
  (let ((text (if check-cutbuffer-p
		  (or (condition-case () (x-get-selection) (error ()))
		      (x-get-cutbuffer)
		      (error "No selection or cut buffer available"))
		(x-get-selection))))
    (cond (move-point-event
	   (mouse-set-point move-point-event)
	   (push-mark (point)))
	  ((interactive-p)
	   (push-mark (point))))
    (insert text)
    ))

(make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
(defun x-set-point-and-insert-selection (event)
  "Set point where clicked and insert the primary selection or the cut buffer."
  (interactive "e")
  (let ((mouse-yank-at-point nil))
    (mouse-yank event)))

(defun x-set-point-and-move-selection (event)
  "Set point where clicked and move the selected text to that location."
  (interactive "e")
  ;; Don't try to move the selection if x-kill-primary-selection if going
  ;; to fail; just let the appropriate error message get issued. (We need
  ;; to insert the selection and set point first, or the selection may
  ;; get inserted at the wrong place.)
  (and (x-selection-owner-p)
       primary-selection-extent
       (x-insert-selection t event))
  (x-kill-primary-selection))

(defun mouse-track-and-copy-to-cutbuffer (event)
  "Make a selection like `mouse-track', but also copy it to the cutbuffer."
  (interactive "e")
  (mouse-track event)
  (cond
   ((null primary-selection-extent)
    nil)
   ((consp primary-selection-extent)
    (save-excursion
      (set-buffer (extent-buffer (car primary-selection-extent)))
      (x-store-cutbuffer
       (mapconcat
	'identity
	(extract-rectangle
	 (extent-start-position (car primary-selection-extent))
	 (extent-end-position (car (reverse primary-selection-extent))))
	"\n"))))
   (t
    (save-excursion
      (set-buffer (extent-buffer primary-selection-extent))
      (x-store-cutbuffer
       (buffer-substring (extent-start-position primary-selection-extent)
			 (extent-end-position primary-selection-extent)))))))


;;; Pointer shape.
;;; This code doesn't allow the mouse cursor and mouse color to be per-frame,
;;; but that wouldn't be hard to do.

;;; #### Should also allow for a cursor object here.

(defvar x-pointer-shape nil
  "*The shape of the mouse-pointer when over text.

This string may be any of the standard cursor names from appendix B 
of the Xlib manual (also known as the file <X11/cursorfont.h>) minus 
the XC_ prefix, or it may be a font name and glyph index of the form 
\"FONT fontname index [[font] index]\", or it may be the name of a
bitmap file acceptable to XmuLocateBitmapFile().  If it is a bitmap
file, and if a bitmap file whose name is the name of the cursor with
\"msk\" exists, then it is used as the mask.  For example, a pair of
files may be named \"cursor.xbm\" and \"cursor.xbmmsk\".")

(defvar x-nontext-pointer-shape nil
  "*The shape of the mouse-pointer when over a buffer, but not over text.  
If this is nil, then `x-pointer-shape' is used.")

(defvar x-mode-pointer-shape nil
  "*The shape of the mouse-pointer when over the modeline.
If this is nil, then either `x-nontext-pointer-shape' or `x-pointer-shape'
will be used.")

(defvar x-selection-pointer-shape nil
  "*The shape of the mouse-pointer when over a selectable text region.")

(defvar x-busy-pointer-shape nil
  "*The shape of the mouse-pointer when Emacs is busy.")

(defvar x-toolbar-pointer-shape nil
  "*The shape of the mouse-pointer when over a toolbar.")

(defvar x-pointer-foreground-color nil
  "*The foreground color of the mouse pointer.")

(defvar x-pointer-background-color nil
  "*The background color of the mouse pointer.")

(defvar x-pointer-cache nil)
(defvar x-pointer-cache-key (make-vector 4 nil))

(defun x-pointer-cache (name fg bg device)
  ;; both must be specified, or neither
  (or (eq (null fg) (null bg))
      (setq fg (or fg
		   (color-instance-name (face-foreground 'default device)))
	    bg (or bg
		   (color-instance-name (face-background 'default device)))))
  (aset x-pointer-cache-key 0 name)
  (aset x-pointer-cache-key 1 fg)
  (aset x-pointer-cache-key 2 bg)
  (aset x-pointer-cache-key 3 device)
  (let (pointer)
    (or (setq pointer (cdr (assoc x-pointer-cache-key x-pointer-cache)))
	(let (tail)
	  (setq x-pointer-cache
		(cons (cons (copy-sequence x-pointer-cache-key)
			    (make-cursor name fg bg device))
		      x-pointer-cache))
	  (setq pointer (cdr (car x-pointer-cache)))
	  (if (setq tail (nthcdr 10 x-pointer-cache))
	      (setcdr tail nil))))
    pointer))

(defvar last-help-echo-object nil)
(defvar help-echo-owns-message nil)

(defun clear-help-echo (&optional ignored-frame)
  (if help-echo-owns-message
      (progn
	(setq help-echo-owns-message nil
	      last-help-echo-object nil)
	(clear-message 'help-echo))))

(defun show-help-echo (mess)
  ;; (clear-help-echo)
  (setq help-echo-owns-message t)
  (display-message 'help-echo mess))

(add-hook 'mouse-leave-frame-hook 'clear-help-echo)

(defun x-track-pointer (event)
  "For use as the value of `mouse-motion-handler'.
This implements `x-pointer-shape' and related variables,
as well as extent highlighting, and `mode-motion-hook'."
  (let* ((frame (or (event-frame event) (selected-frame)))
	 (device (frame-device frame))
	 (buffer (event-buffer event))
	 (point (and buffer (event-point event)))
	 (extent (and point (extent-at point buffer 'highlight)))
	 (glyph (event-glyph-extent event))
	 (button (event-toolbar-button event))
	 (help (or (and glyph (extent-property glyph 'help-echo) glyph)
		   (and button (not (null (toolbar-button-help-string button)))
			button)
		   (and point
			(condition-case nil
			    (extent-at point buffer 'help-echo)
			  (error nil)))))
	 (var (cond ((and extent x-selection-pointer-shape)
		     'x-selection-pointer-shape)
		    ;; Checking if button is non-nil is not sufficent
		    ;; since the pointer could be over a blank portion
		    ;; of the toolbar.
		    ((event-over-toolbar-p event) 'x-toolbar-pointer-shape)
		    (glyph 'x-selection-pointer-shape)
		    (point 'x-pointer-shape)
		    ((event-over-modeline-p event) 'x-mode-pointer-shape)
		    (buffer
		     (cond (x-nontext-pointer-shape 'x-nontext-pointer-shape)
			   (x-pointer-shape 'x-pointer-shape)))
		    (t (cond (x-mode-pointer-shape 'x-mode-pointer-shape)
			     (x-nontext-pointer-shape 'x-nontext-pointer-shape)
			     (x-pointer-shape 'x-pointer-shape)))))
	 pointer scrollbar-pointer)
    (condition-case c
	(progn
	  (setq pointer (x-pointer-cache (symbol-value var)
					  x-pointer-foreground-color
					  x-pointer-background-color
					  device))
	  (x-set-frame-pointer frame pointer))
      (error
       (x-track-pointer-damage-control c var device)))
    (condition-case c
	(progn
	  (setq scrollbar-pointer
		(if x-scrollbar-pointer-shape
		    (x-pointer-cache x-scrollbar-pointer-shape
				     x-pointer-foreground-color
				     x-pointer-background-color
				     device)
		  pointer))
	  (x-set-scrollbar-pointer frame scrollbar-pointer))
      (error
       (x-track-pointer-damage-control c 'x-scrollbar-pointer-shape device)))

    ;; If last-pressed-toolbar-button is not nil, then check and see
    ;; if we have moved to a new button and adjust the down flags
    ;; accordingly.
    (if toolbar-active
	(if (not (eq last-pressed-toolbar-button button))
	    (progn
	      (release-previous-toolbar-button event)
	      (and button (press-toolbar-button event)))))
	  
    (cond (extent (highlight-extent extent t))
	  (glyph (highlight-extent glyph t))
	  (t (highlight-extent nil nil)))
    (cond ((extentp help)
           (or inhibit-help-echo
               (eq help last-help-echo-object) ;save some time
               (let ((hprop (extent-property help 'help-echo)))
                 (setq last-help-echo-object help)
                 (or (stringp hprop)
                     (setq hprop (funcall hprop help)))
                 (and hprop (show-help-echo hprop)))))
	  ((and (toolbar-button-p help) (toolbar-button-enabled-p help))
	   (or (not toolbar-help-enabled)
	       (eq help last-help-echo-object) ;save some time
	       (let ((hstring (toolbar-button-help-string button)))
		 (setq last-help-echo-object help)
		 (or (stringp hstring)
		     (setq hstring (funcall hstring help)))
		 (show-help-echo hstring))))
          (last-help-echo-object
	   (clear-help-echo)))
    (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
    (if buffer
	(save-window-excursion
	  (set-buffer buffer)
	  (run-hook-with-args 'mode-motion-hook event)

	  ;; If the mode-motion-hook created a highlightable extent around
	  ;; the mouse-point, highlight it right away.  Otherwise it wouldn't
	  ;; be highlighted until the *next* motion event came in.
	  (if (and point
		   (null extent)
		   (setq extent (extent-at point
					   (event-buffer event) ; not buffer
					   'highlight)))
	      (highlight-extent extent t)))))
  nil)

(defun x-track-pointer-damage-control (c var device)
  ;; When x-set-frame-pointer signals an error, this function tries to figure
  ;; out why, and undo the damage so that an error isn't signalled every time
  ;; the mouse moves.
  (cond ((and (stringp (nth 1 c))
	      (or (string= (nth 1 c) "unknown cursor")
		  (string-match "xpm\\|XPM\\|pixmap\\|bitmap" (nth 1 c))))
	 (set var nil)
	 (error "%S was %S, which is an invalid X cursor name.  Reset."
		var (nth 2 c)))
	((string= (nth 1 c) "unrecognised color")
	 (if (not (valid-color-name-p x-pointer-foreground-color device))
	     (setq var 'x-pointer-foreground-color)
	   (if (not (valid-color-name-p x-pointer-background-color device))
	       (setq var 'x-pointer-background-color)
	     (error "got %S and I don't know why!" c)))
	 (set var nil)
	 (error "%S was %S, which was an invalid color name.  Reset."
		var (nth 2 c)))
	((string= (nth 1 c) "couldn't allocate color")
	 (cond ((string= (nth 2 c) x-pointer-foreground-color)
		(setq var 'x-pointer-foreground-color))
	       ((string= (nth 2 c) x-pointer-background-color)
		(setq var 'x-pointer-background-color))
	       (t (error "got %S and I don't know why!" c)))
	 (set var nil)
	 (error "%S was %S, which cannot be allocated.  Reset."
		var (nth 2 c)))
	((eq (car c) 'wrong-type-argument)
	 (let ((rest '(x-pointer-foreground-color x-pointer-background-color
		       x-pointer-shape x-nontext-pointer-shape
		       x-mode-pointer-shape x-scrollbar-pointer-shape)))
	   (while rest
	     (if (and (symbol-value (car rest))
		      (not (stringp (symbol-value (car rest)))))
		 (progn
		   (set (car rest) nil)
		   (error "%S was %S, not a string.  Reset." (car rest)
			  (nth 2 c))))
	     (setq rest (cdr rest)))
	   (error "got %S and I don't know why!" c)))
	(t (signal (car c) (cdr c)))))


;;; GC pointer shape

;; For the mystified out there, the GC pointer is stored in the variable
;; `gc-message', which is defined in alloc.c.  If the value of this is
;; a cursor, the function x_show_gc_cursor(), defined in xfns.c, is called
;; at the beginning of garbage collection.

(defun x-set-pointer-for-gc ()
  (if (or (not (eq 'x (device-type (selected-device))))
	  (null x-gc-pointer-shape))
      (setq gc-message nil)
    ;; else
    (condition-case error
	(setq gc-message (x-pointer-cache x-gc-pointer-shape
					  x-pointer-foreground-color
					  x-pointer-background-color
					  (selected-device)))
      (error
       ;; This conses a little bit but not much.  Should be ok.
       (setq gc-message nil)
       (let ((b (get-buffer-create " *gc-pointer-error*")))
	 (save-excursion
	   (set-buffer b)
	   (erase-buffer)
	   (insert "Garbage collecting... ERROR setting GC pointer: ")
	   (display-error error b)
	   (display-warning 'pointer (buffer-string)))
	 (kill-buffer b))))))

(add-hook 'pre-gc-hook 'x-set-pointer-for-gc)


(defvar x-pointers-initialized nil)

(defun x-init-pointer-shape (device)
  "Initializes the mouse-pointers of the given device from the resource
database."
  ;; #### nyet nyet nyet!  Need to extend cursors and x-pointer-shape
  ;; to be device-specific.
  (if x-pointers-initialized  ; only do it when the first device is created
      nil
    (setq x-pointer-shape
	  (or (x-get-resource "textPointer" "Cursor" 'string device)
	      "xterm"))
    (setq x-selection-pointer-shape
	  (or (x-get-resource "selectionPointer" "Cursor" 'string device)
	      "top_left_arrow"))
    (setq x-nontext-pointer-shape
	  (or (x-get-resource "spacePointer" "Cursor" 'string device)
	      "xterm")) ; was "crosshair"
    (setq x-mode-pointer-shape
	  (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
	      "sb_v_double_arrow"))
    (setq x-gc-pointer-shape
	  (or (x-get-resource "gcPointer" "Cursor" 'string device)
	      "watch"))
    (setq x-scrollbar-pointer-shape
	  (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
	      "top_left_arrow"))
    (setq x-busy-pointer-shape
	  (or (x-get-resource "busyPointer" "Cursor" 'string device)
	      "watch"))
    (setq x-toolbar-pointer-shape
	  (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
	      "left_ptr"))
    (setq x-pointer-foreground-color
	  (x-get-resource "pointerColor" "Foreground" 'string device))
    (setq x-pointer-background-color
	  (x-get-resource "pointerBackground" "Background" 'string device))
    (setq x-pointers-initialized t))
  nil)
