From 6091b3e89519cd2dbfda1307dd2f04a493ac7dce Mon Sep 17 00:00:00 2001 Message-Id: <6091b3e89519cd2dbfda1307dd2f04a493ac7dce.1719103476.git.mdw@distorted.org.uk> From: Mark Wooding Date: Tue, 25 Apr 2006 20:19:32 +0000 Subject: [PATCH 1/1] Changes to cursor bindings Organization: Straylight/Edgeware From: espen --- gdk/gdk.lisp | 21 ++++++++++++++------- gtk/gtkwidget.lisp | 10 +++++++--- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index c285f99..82007a2 100644 --- a/gdk/gdk.lisp +++ b/gdk/gdk.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gdk.lisp,v 1.26 2006/04/25 13:37:28 espen Exp $ +;; $Id: gdk.lisp,v 1.27 2006/04/25 20:19:32 espen Exp $ (in-package "GDK") @@ -422,13 +422,20 @@ (defbinding rgb-init () nil) ;;; Cursor -(defmethod allocate-foreign ((cursor cursor) &key type mask fg bg +(defmethod allocate-foreign ((cursor cursor) &key source mask fg bg (x 0) (y 0) (display (display-get-default))) - (etypecase type - (keyword (%cursor-new-for-display display type)) - (pixbuf (%cursor-new-from-pixbuf display type x y)) - (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))) - + (etypecase source + (keyword (%cursor-new-for-display display source)) + (pixbuf (%cursor-new-from-pixbuf display source x y)) + (pixmap (%cursor-new-from-pixmap source mask + (or fg (ensure-color #(0.0 0.0 0.0))) + (or bg (ensure-color #(1.0 1.0 1.0))) x y)) + (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y)))) + +(defun ensure-cursor (cursor &rest args) + (if (typep cursor 'cursor) + cursor + (apply #'make-instance 'cursor :type cursor args))) (defbinding %cursor-new-for-display () pointer (display display) diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp index 0a9c48a..0a560c5 100644 --- a/gtk/gtkwidget.lisp +++ b/gtk/gtkwidget.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkwidget.lisp,v 1.21 2006/04/10 18:42:08 espen Exp $ +;; $Id: gtkwidget.lisp,v 1.22 2006/04/25 20:19:32 espen Exp $ (in-package "GTK") @@ -488,8 +488,12 @@ (defbinding get-event-widget () widget (event gdk:event)) (defun (setf widget-cursor) (cursor-type widget) - (let ((cursor (make-instance 'gdk:cursor :type cursor-type))) - (gdk:window-set-cursor (widget-window widget) cursor))) + (warn "(SETF WIDGET-CURSOR) is deprecated, use WIDGET-SET-CURSOR instead") + (widget-set-cursor widget cursor-type)) + +(defun widget-set-cursor (widget cursor &rest args) + (gdk:window-set-cursor (widget-window widget) + (apply #'gdk:ensure-cursor cursor args))) (defbinding %widget-get-parent-window () gdk:window (widget widget)) -- [mdw]