Added set-fix-widget-enter/leave-notify-handler!, -pointer-shape!.

New: set-fix-widget-enter-notify-handler!
     set-fix-widget-leave-notify-handler!
     set-fix-widget-pointer-shape!

Updated: gdk_cursor_unref (gdk_cursor_destroy is deprecated),
         gtk_widget_set_state (new for fix-resizer's enter/leave
         handlers).

Consistency nits: prefering symbol-name over symbol->string, tracing
entry to specialized methods AFTER call-next-method.

Exercised pointer shape setting in <fix-resizer> demo.

diff --git a/src/gtk/Includes/gdkcursor.cdecl b/src/gtk/Includes/gdkcursor.cdecl
index ed2f60634c93823a020a3cff323ea65c5395d685..ba6f7fe4515dbdc200da7653146ba2553ea0ffbe 100644 (file)
--- a/src/gtk/Includes/gdkcursor.cdecl
+++ b/src/gtk/Includes/gdkcursor.cdecl
@@ -95,5 +95,5 @@ gtk-2.0/gdk/gdkcursor.h |#
 (extern (* GdkCursor) gdk_cursor_new
        (cursor_type GdkCursorType))
 
-(extern void gdk_cursor_destroy
+(extern void gdk_cursor_unref
        (cursor (* GdkCursor)))
\ No newline at end of file

diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl
index cda3da9726f85ced962d7eb05399a2a0c8bde22f..8481d22fbf735253ecb0d6f872e9b4b51b75d230 100644 (file)
--- a/src/gtk/Includes/gdkwindow.cdecl
+++ b/src/gtk/Includes/gdkwindow.cdecl
@@ -212,6 +212,10 @@ gtk-2.0/gdk/gdkwindow.h |#
        (dx gint)
        (dy gint))
 
+(extern void gdk_window_set_cursor
+       (window (* GdkWindow))
+       (cursor (* GdkCursor)))
+
 (extern void
        gdk_window_invalidate_rect
        (window (* GdkWindow))

diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl
index c94a0505412fc25226d64b2605ba5be7308ee3da..3ad38ebf5097a149c7929e6631891cb018df47aa 100644 (file)
--- a/src/gtk/Includes/gtkwidget.cdecl
+++ b/src/gtk/Includes/gtkwidget.cdecl
@@ -315,6 +315,10 @@ gtk-2.0/gtk/gtkwidget.h |#
 (extern void gtk_widget_grab_focus
        (widget (* GtkWidget)))
 
+(extern void gtk_widget_set_state
+       (widget (* GtkWidget))
+       (state GtkStateType))
+
 (extern void gtk_widget_set_has_window
        (widget (* GtkWidget))
        (has_window gboolean))

diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm
index 1176b85a809ba76faac12da8d368f870017a9818..2049eb9c601c52289a0321af594eae7609060981 100644 (file)
--- a/src/gtk/compile.scm
+++ b/src/gtk/compile.scm
@@ -35,8 +35,8 @@
                    ("pango"          ,@base)
                    ("gtk-object"     ,@base)
                    ("scm-widget"     ,@base)
-                   ("fix-layout"     "pango" ,@base)
-                   ("keys"           ,@base)
+                   ("fix-layout"     "pango" ,@base ,@c-types)
+                   ("keys"           ,@base ,@c-types)
                    ("main"           ,@base)
                    ("thread"         "main" ,@user)
                    ("gtk-ev"         ,@base)

diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm
index ec49c7d933b86c06401d106bc32f93daa4a88b4d..3e615c368575e0b6f8c0f6ac4024a3db24d067cb 100644 (file)
--- a/src/gtk/fix-demo.scm
+++ b/src/gtk/fix-demo.scm
@@ -37,7 +37,6 @@ USA.
         (resizer (make-fix-resizer -1 10)))
     (gtk-window-set-opacity window 0.90)
     (gtk-window-set-title window "fix-layout-demo")
-    ;;(gtk-window-set-default-size window 200 400)
     (set-gtk-window-delete-event-callback!
      window (lambda (w) (%trace ";closed "w"\n") 0))
     (gtk-container-set-border-width window 10)
@@ -83,7 +82,8 @@ USA.
 
 (define-method fix-widget-realize-callback ((widget <demo-layout>))
   (call-next-method widget)
-  (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget)))
+  (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))
+  (set-fix-widget-pointer-shape! widget 'crosshair))
 
 (define (make-demo-drawing widget)
   (let ((drawing (%make-demo-drawing)))

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index db31dee14fd4e10d9b313021e8b1b86cfcb328c9..199094017a48b3fed1c94c03287f4c5bbafa660a 100644 (file)
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -205,6 +205,38 @@ USA.
        (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL"))
        ;; The GdkColor was allocated by the GtkStyle.
        (C-call "gdk_window_set_background" (fix-widget-window widget) alien))))
+
+(define-syntax pointer-shapes
+  (sc-macro-transformer
+   (lambda (form usage-env)
+
+     (define (simplify name)
+       ;; |GDK_BASED_ARROW_DOWN| => based-arrow-down
+       (let ((string (symbol-name name)))
+        (if (string-prefix? "GDK_" string)
+            (intern (string-replace (string-tail string 4) #\_ #\-))
+            (begin
+              (warn "Unexpected GdkCursorType name:" name)
+              name))))
+
+     (list 'quote
+          (map (lambda (name.value)
+                 (cons (simplify (car name.value))
+                       (cdr name.value)))
+               (c-enum-constant-values '|GdkCursorType| form
+                                       (find-c-includes usage-env)))))))
+
+(define set-fix-widget-pointer-shape!
+  (let ((alist (pointer-shapes)))
+    (named-lambda (set-fix-widget-pointer-shape! widget name)
+      (let ((name.value (or (assq name alist)
+                           (error "Not a pointer shape:" name
+                                  (map car alist))))
+           (alien (make-alien '|GdkCursor|)))
+       ;; Not GC-protecting alien?
+       (C-call "gdk_cursor_new" alien (cdr name.value))
+       (C-call "gdk_window_set_cursor" (fix-widget-window widget) alien)
+       (C-call "gdk_cursor_unref" alien)))))
 \f
 (define (event-callback widget GdkEvent)
   (%trace2 ";event-callback "widget)
@@ -255,6 +287,24 @@ USA.
      (declare (ignore GdkEvent))
      (handler widget))))
 
+(define (set-fix-widget-enter-notify-handler! widget handler)
+  (guarantee-fix-widget widget 'set-fix-widget-enter-notify-handler!)
+  (guarantee-procedure-of-arity handler 1 'set-fix-widget-enter-notify-handler!)
+  (vector-set!
+   (fix-widget-event-handlers widget) (C-enum "GDK_ENTER_NOTIFY")
+   (named-lambda (fix-widget-enter-notify-handler widget GdkEvent)
+     (declare (ignore GdkEvent))
+     (handler widget))))
+
+(define (set-fix-widget-leave-notify-handler! widget handler)
+  (guarantee-fix-widget widget 'set-fix-widget-leave-notify-handler!)
+  (guarantee-procedure-of-arity handler 1 'set-fix-widget-leave-notify-handler!)
+  (vector-set!
+   (fix-widget-event-handlers widget) (C-enum "GDK_LEAVE_NOTIFY")
+   (named-lambda (fix-widget-leave-notify-handler widget GdkEvent)
+     (declare (ignore GdkEvent))
+     (handler widget))))
+
 (define (set-fix-widget-focus-change-handler! widget handler)
   (guarantee-fix-widget widget 'set-fix-widget-focus-change-handler!)
   (guarantee-procedure-of-arity handler 2 'set-fix-widget-focus-change-handler!)
@@ -400,7 +450,6 @@ USA.
 (define-guarantee fix-layout "a <fix-layout>")
 
 (define-method initialize-instance ((widget <fix-layout>) width height)
-
   (call-next-method widget width height)
   (%trace "; (initialize-instance <fix-layout>) "widget" "width" "height"\n")
   (set-fix-widget-expose-handler! widget layout-expose-handler)
@@ -670,11 +719,21 @@ USA.
 (define-class (<fix-resizer> (constructor () (width height)))
     (<fix-widget>))
 
-(define-method initialize-instance ((widget <fix-resizer>) width height)
-  (call-next-method widget width height)
-  (set-fix-widget-expose-handler! widget resizer-expose-handler))
+(define-method fix-widget-realize-callback ((widget <fix-resizer>))
+  (call-next-method widget)
+  (%trace "; (fix-widget-realize-callback <fix-resizer>) "widget"\n")
+  (let ((geom (fix-widget-geometry widget)))
+    (set-fix-widget-pointer-shape!
+     widget (if (fix:< (fix-rect-width geom)
+                      (fix-rect-height geom))
+               'sb-h-double-arrow
+               'sb-v-double-arrow)))
+  (set-fix-widget-expose-handler! widget resizer-expose-handler)
+  (set-fix-widget-enter-notify-handler! widget resizer-enter-handler)
+  (set-fix-widget-leave-notify-handler! widget resizer-leave-handler))
 
 (define (resizer-expose-handler resizer x y width height)
+  (declare (ignore x y width height))
   (let ((alien (gobject-alien resizer)))
     (let ((style (C-> alien "GtkWidget style"))
          (window (fix-widget-window resizer))
@@ -694,6 +753,16 @@ USA.
                (fix-rect-width geom) (fix-rect-height geom)
                orientation)
        #t))))
+
+(define (resizer-enter-handler resizer)
+  (outf-error ";resizer-enter-handler\n")
+  (C-call "gtk_widget_set_state"
+         (gobject-alien resizer) (C-enum "GTK_STATE_PRELIGHT")))
+
+(define (resizer-leave-handler resizer)
+  (outf-error ";resizer-leave-handler\n")
+  (C-call "gtk_widget_set_state"
+         (gobject-alien resizer) (C-enum "GTK_STATE_NORMAL")))
 \f
 (define-class (<fix-drawing> (constructor () no-init))
     ()
@@ -1636,8 +1705,8 @@ USA.
   (loader define standard initializer make-pixbuf-loader))
 
 (define-method initialize-instance ((ink <image-ink>))
-  (%trace ";(initialize-instance <image-ink>) "ink"\n")
   (call-next-method ink)
+  (%trace ";(initialize-instance <image-ink>) "ink"\n")
   (let ((loader (image-ink-loader ink)))
     (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink))
     (set-pixbuf-loader-pixbuf-hook! loader (image-ink-pixbuf-prepared ink))

diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm
index 9f2fe8b2ed030967ff48ece1f4fe59ffcdce02f2..6c06241137de9cae64facb5eed02a60da418d8a4 100644 (file)
--- a/src/gtk/gtk-ev.scm
+++ b/src/gtk/gtk-ev.scm
@@ -119,7 +119,7 @@ USA.
     (error-if-null event-GdkWindow "Could not create event window:" widget)
     (C-call "gdk_window_set_user_data" event-GdkWindow alien)
     (C-call "gdk_window_show" event-GdkWindow)
-    (C-call "gdk_cursor_destroy" GdkCursor)
+    (C-call "gdk_cursor_unref" GdkCursor)
 
     ;; Style
     (C-call "gtk_style_attach" GtkStyle

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 0ae0767077a465acabded9366bae4aca23906a06..682cd352fbe0aa18a20fed5e1b96bd2a98bf5586 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -211,7 +211,10 @@ USA.
 (define-package (gtk fix-layout)
   (parent (gtk))
   (files "fix-layout")
-  ;;(depends-on "pango" "gtk.bin" "gtk" "../runtime/ffi")
+  ;;(depends-on "pango" "gtk.bin" gtk" "../runtime/ffi" "gtk-const.bin")
+  (import (ffi)
+         find-c-includes
+         c-enum-constant-values)
   (import (gtk pango)
           make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
   (import (gtk gtk-object)
@@ -222,9 +225,12 @@ USA.
          fix-widget?
          fix-widget-new-geometry-callback fix-widget-realize-callback
          set-fix-widget-size!
+         set-fix-widget-pointer-shape!
          set-fix-widget-expose-handler!
          set-fix-widget-map-handler!
          set-fix-widget-unmap-handler!
+         set-fix-widget-enter-notify-handler!
+         set-fix-widget-leave-notify-handler!
          set-fix-widget-focus-change-handler!
          set-fix-widget-visibility-notify-handler!
          set-fix-widget-key-press-handler!
@@ -290,7 +296,7 @@ USA.
 (define-package (gtk keys)
   (parent (gtk))
   (files "keys")
-  ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi")
+  ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "gtk-const.bin")
   (export (gtk)
          gdk-key-state->char-bits
          gdk-keyval->name)

diff --git a/src/gtk/keys.scm b/src/gtk/keys.scm
index b24ffbf345c7d941bb1d3539dec5372c79af6873..7bcaf72607e5be8565115c0a267681962a5be41f 100644 (file)
--- a/src/gtk/keys.scm
+++ b/src/gtk/keys.scm
@@ -53,7 +53,7 @@ USA.
             (lambda (gdk-name.keyval)
               (let* ((keyval (cdr gdk-name.keyval))
                      (gdk-name (car gdk-name.keyval))
-                     (string (symbol->string gdk-name))
+                     (string (symbol-name gdk-name))
                      (name (cond ((assv keyval overrides) => cdr)
                                  ((string-prefix? "GDK_" string)
                                   (intern (string-replace