WIDGET CALLBACKS!!!

4 files changed, 58 insertions, 1 deletions

diff --git a/c_fl_widget.cpp b/c_fl_widget.cpp
index a503dc1..f700c54 100644
--- a/c_fl_widget.cpp
+++ b/c_fl_widget.cpp
@@ -72,3 +72,10 @@ void * fl_widget_get_parent(WIDGET w) {
     return reinterpret_cast<Fl_Widget*>(w)->parent();
 }
 
+
+
+
+void fl_widget_set_callback(WIDGET w, void * cb) {
+    reinterpret_cast<Fl_Widget*>(w)->callback(reinterpret_cast<Fl_Callback_p>(cb));
+}
+
diff --git a/c_fl_widget.h b/c_fl_widget.h
index 8f99d26..3b2561e 100644
--- a/c_fl_widget.h
+++ b/c_fl_widget.h
@@ -24,5 +24,8 @@ extern "C" void fl_widget_set_label_type(WIDGET w, int l);
 extern "C" void * fl_widget_get_parent(WIDGET w);
 
 
+extern "C" void fl_widget_set_callback(WIDGET w, void * cb);
+
+
 #endif
 
diff --git a/fltk-widgets.adb b/fltk-widgets.adb
index 0f67ddb..3e27cb7 100644
--- a/fltk-widgets.adb
+++ b/fltk-widgets.adb
@@ -71,6 +71,10 @@ package body FLTK.Widgets is
         return System.Address;
     pragma Import (C, fl_widget_get_parent, "fl_widget_get_parent");
 
+    procedure fl_widget_set_callback
+           (W, C : in System.Address);
+    pragma Import (C, fl_widget_set_callback, "fl_widget_set_callback");
+
 
 
 
@@ -190,5 +194,34 @@ package body FLTK.Widgets is
     end Set_Label_Type;
 
 
+
+
+    --  this is the part called by FLTK callbacks
+    --  note that the user data portion is a reference back to the Ada binding
+    procedure Callback_Hook (W, U : in System.Address);
+    pragma Convention (C, Callback_Hook);
+
+    procedure Callback_Hook
+           (W, U : in System.Address) is
+
+        Ada_Widget : access Widget'Class :=
+            Widget_Convert.To_Pointer (U);
+
+    begin
+        Ada_Widget.Callback.Call (Ada_Widget.all);
+    end Callback_Hook;
+
+
+
+
+    procedure Set_Callback
+           (This : in out Widget;
+            Func : not null access Widget_Callback'Class) is
+    begin
+        This.Callback := Func;
+        fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+    end Set_Callback;
+
+
 end FLTK.Widgets;
 
diff --git a/fltk-widgets.ads b/fltk-widgets.ads
index 3f02302..1c21ca4 100644
--- a/fltk-widgets.ads
+++ b/fltk-widgets.ads
@@ -14,6 +14,12 @@ package FLTK.Widgets is
         with Implicit_Dereference => Data;
 
 
+    type Widget_Callback is interface;
+    procedure Call
+           (This : in     Widget_Callback;
+            Item : in out Widget'Class) is abstract;
+
+
     --  would like to move this definition to FLTK.Widgets.Groups somehow
     type Group_Cursor (Data : access FLTK.Widgets.Groups.Group'Class) is limited null record
         with Implicit_Dereference => Data;
@@ -85,10 +91,18 @@ package FLTK.Widgets is
             Label : in     Label_Kind);
 
 
+    procedure Set_Callback
+           (This : in out Widget;
+            Func : not null access Widget_Callback'Class);
+
+
 private
 
 
-    type Widget is abstract new Wrapper with null record;
+    type Widget is abstract new Wrapper with
+        record
+            Callback : access Widget_Callback'Class;
+        end record;
 
 
     package Widget_Convert is new System.Address_To_Access_Conversions (Widget'Class);