[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp

[Andy Hefner]

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX
In directory common-lisp.net:/tmp/cvs-serv14626/Backends/CLX

Modified Files:
	port.lisp 
Log Message:
Fix bug in text selection code causing an error if the user attempts to
drag a selection endpoint before any text has been selected.

Fix to decode-x-button-code for users with more than five mouse buttons.


Date: Sun Jan  2 06:29:03 2005
Author: ahefner

Index: mcclim/Backends/CLX/port.lisp
diff -u mcclim/Backends/CLX/port.lisp:1.101 mcclim/Backends/CLX/port.lisp:1.102
--- mcclim/Backends/CLX/port.lisp:1.101	Tue Dec 28 11:06:21 2004
+++ mcclim/Backends/CLX/port.lisp	Sun Jan  2 06:29:03 2005
@@ -238,8 +238,9 @@
       (setf (xlib:display-error-handler (clx-port-display port))
         #'clx-error-handler)
 
-      #+nil
+      #+nil ;; Uncomment this when debugging CLX backend if asynchronous errors become troublesome..
       (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-force-output))
+      
     
     (setf (clx-port-screen port) (nth (getf options :screen-id 0)
 				      (xlib:display-roots (clx-port-display port))))
@@ -531,13 +532,16 @@
                (progn
                  , at body)))))))
 
-(defun decode-x-button-code (code)
-  (aref #.(vector +pointer-left-button+
-                  +pointer-middle-button+
-                  +pointer-right-button+
-		  +pointer-wheel-up+
-		  +pointer-wheel-down+)
-        (1- code)))
+(defun decode-x-button-code (code)  
+  (let ((button-mapping #.(vector +pointer-left-button+
+                                  +pointer-middle-button+
+                                  +pointer-right-button+
+                                  +pointer-wheel-up+
+                                  +pointer-wheel-down+)))
+    (if (and (> code 0)
+             (<= code (1+ (length button-mapping))))
+        (aref button-mapping (1- code))
+        nil)))
 
 ;; From "Inter-Client Communication Conventions Manual", Version 2.0.xf86.1,
 ;; section 4.1.5:
@@ -1063,7 +1067,8 @@
     (or (gethash color table)
 	(setf (gethash color table)
 	      (multiple-value-bind (r g b) (color-rgb color)
-		(xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port))
+		(xlib:alloc-color (xlib:screen-default-colormap
+                                   (clx-port-screen port))
 				  (xlib:make-color :red r :green g :blue b)))))))
 
 (defmethod port-mirror-width ((port clx-port) sheet)
@@ -1352,6 +1357,8 @@
   (xlib:convert-selection :primary :UTF8_STRING requestor :bounce time))
 
 (defmethod get-selection-from-event ((event clx-selection-notify-event))
+  (when (null (selection-event-property event))
+    (format *trace-output* "~&;; Notify property is null! Why did this happen?~%"))
   (map 'string #'code-char
        (xlib:get-property (sheet-direct-mirror (event-sheet event))
                           (selection-event-property event)
@@ -1364,8 +1371,10 @@
         (property  (selection-event-property event))
         (target    (selection-event-target event))
         (time      (event-timestamp event)))
-;    (describe event *trace-output*)
-;    (finish-output *trace-output*)
+    (when (null property)
+      (format *trace-output* "~&* Requestor property is null! *~%"))
+    (describe event *trace-output*)
+    (finish-output *trace-output*)
     (cond ((member target '(:UTF8_STRING :STRING :TEXT))
            (xlib:change-property requestor property
                                  (utf-8-encode