Update from before ChristmasHEADmaster

6 files changed, 686 insertions, 21 deletions

diff --git a/src/c_wayland_client.c b/src/c_wayland_client.c
new file mode 100644
index 0000000..bdd62e6
--- /dev/null
+++ b/src/c_wayland_client.c
@@ -0,0 +1,45 @@
+
+
+#include <stdio.h>
+#include <wayland-client-core.h>
+#include "c_wayland_client.h"
+
+
+log_hook_t ada_handler;
+char buf[256];
+
+
+void actual_log_handler(const char *c, va_list va) {
+    char *str = buf;
+    char *extra = NULL;
+    int len;
+
+    if (c == NULL) {
+        (*ada_handler)(c,0);
+        return;
+    }
+
+    len = vsnprintf(str, 256, c, va);
+    if (len >= 256) {
+        extra = malloc((len + 1) * sizeof(char));
+        if (extra == NULL) {
+            (*ada_handler)(extra,1);
+            return;
+        }
+        str = extra;
+        vsnprintf(str, len + 1, c, va);
+    }
+
+    (*ada_handler)(str,0);
+
+    if (extra != NULL) {
+        free(extra);
+    }
+}
+
+
+void wayland_client_set_log_hook(log_hook_t func) {
+    ada_handler = func;
+    wl_log_set_handler_client(&actual_log_handler);
+}
+
diff --git a/src/c_wayland_client.h b/src/c_wayland_client.h
new file mode 100644
index 0000000..0a22a50
--- /dev/null
+++ b/src/c_wayland_client.h
@@ -0,0 +1,14 @@
+
+
+#ifndef C_WAYLAND_CLIENT_BINDING
+#define C_WAYLAND_CLIENT_BINDING
+
+
+typedef void (*log_hook_t)(char *msg, int fail);
+
+
+void wayland_client_set_log_hook(log_hook_t func);
+
+
+#endif
+
diff --git a/src/wayland-client.adb b/src/wayland-client.adb
new file mode 100644
index 0000000..21d5cc2
--- /dev/null
+++ b/src/wayland-client.adb
@@ -0,0 +1,544 @@
+
+
+with
+
+    Interfaces.C.Strings;
+
+
+package body Wayland.Client is
+
+
+    --  C constructors
+
+    function wl_proxy_create
+           (P, I : in System.Address)
+        return System.Address
+        with Convention => C,
+             Import => True;
+
+    function wl_display_connect
+           (N : in Interfaces.C.Strings.chars_ptr)
+        return System.Address
+        with Convention => C,
+             Import => True;
+
+    function wl_display_connect_to_fd
+           (FD : in Interfaces.C.int)
+        return System.Address
+        with Convention => C,
+             Import => True;
+
+    function wl_display_create_queue
+           (D : in System.Address)
+        return System.Address
+        with Convention => C,
+             Import => True;
+
+
+
+
+
+    --  C destructors
+
+    procedure wl_proxy_destroy
+           (P : in System.Address)
+        with Convention => C,
+             Import => True;
+
+    procedure wl_display_disconnect
+           (D : in System.Address)
+        with Convention => C,
+             Import => True;
+
+    procedure wl_event_queue_destroy
+           (E : in System.Address)
+        with Convention => C,
+             Import => True;
+
+
+
+
+
+    --  C proxy functions
+
+    function wl_proxy_get_version
+           (P : in System.Address)
+        return Interfaces.C.Unsigned
+        with Convention => C,
+             Import => True;
+
+    function wl_proxy_get_version
+           (P : in System.Address)
+        return Interfaces.C.Unsigned
+        with Convention => C,
+             Import => True;
+
+    function wl_proxy_get_class
+           (P : in System.Address)
+        return Interfaces.C.Strings.chars_ptr
+        with Convention => C,
+             Import => True;
+
+    procedure wl_proxy_set_queue
+           (P, E : in System.Address)
+        with Convention => C,
+             Import => True;
+
+
+
+
+
+    --  C display functions
+
+    function wl_display_get_fd
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_dispatch
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_dispatch_pending
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_dispatch_queue
+           (D, Q : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_dispatch_queue_pending
+           (D, Q : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_get_error
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_get_protocol_error
+           (D, P : in System.Address;
+            ID   : in Interfaces.C.unsigned)
+        return Interfaces.C.unsigned
+        with Convention => C,
+             Import => True;
+
+    function wl_display_flush
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_roundtrip_queue
+           (D, Q : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_roundtrip
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_prepare_read
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_prepare_read_queue
+           (D, Q : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+    function wl_display_read_events
+           (D : in System.Address)
+        return Interfaces.C.int
+        with Convention => C,
+             Import => True;
+
+
+
+
+
+    --  C log handling
+
+    procedure wayland_client_set_log_hook
+           (F : in System.Address)
+        with Convention => C,
+             Import => True;
+
+
+
+
+
+    --  Ada Destructors
+
+    procedure Finalize
+           (This : in out Proxy) is
+    begin
+        if This.Void_Ptr /= System.Null_Address then
+            wl_proxy_destroy (This.Void_Ptr);
+            This.Void_Ptr := System.Null_Address;
+        end if;
+    end Finalize;
+
+
+    procedure Finalize
+           (This : in out Display) is
+    begin
+        if This.Void_Ptr /= System.Null_Address then
+            wl_display_disconnect (This.Void_Ptr);
+            This.Void_Ptr := System.Null_Address;
+        end if;
+    end Finalize;
+
+
+    procedure Finalize
+           (This : in out Event_Queue) is
+    begin
+        if This.Void_Ptr /= System.Null_Address then
+            wl_event_queue_destroy (This.Void_Ptr);
+            This.Void_Ptr := System.Null_Address;
+        end if;
+    end Finalize;
+
+
+
+
+
+    --  Internal callback hooks
+
+    function Dispatcher_Hook
+           (P, V : in System.Address;
+            Op   : in Opcode;
+            M    : in Message_Signature;
+            Args : in Argument_Array)
+    is
+        This_Proxy : access Proxy'Class :=
+            Proxy_Convert.To_Pointer (P);
+    begin
+        
+    end Dispatcher_Hook;
+
+
+    Current_Log_Function : Log_Function := null;
+
+    procedure Log_Function_Hook
+           (Msg  : in Interfaces.C.Strings.chars_ptr;
+            Fail : in Interfaces.C.int)
+        with Convention => C,
+             Export => True
+    is
+        Text : String := Interfaces.C.Strings.Value (Msg);
+    begin
+        if Fail /= 0 then
+            raise Storage_Error;
+        end if;
+
+        if Current_Log_Function /= null then
+            Current_Log_Function.all (Text);
+        end if;
+    end Log_Function_Hook;
+
+
+
+
+
+    --  Proxy
+
+    function Create
+           (Factory      : in Proxy;
+            My_Interface : in Protocol_Interface)
+        return Proxy
+    is
+        Ptr : System.Address :=
+            wl_proxy_create (Factor.Void_Ptr, My_Interface.Void_Ptr);
+    begin
+        if Ptr = System.Null_Address then
+            raise Storage_Error;
+        end if;
+
+        return This : Proxy do
+            This.Void_Ptr := Ptr;
+            This.Current_Dispatcher := null;
+            
+        end return;
+    end Create;
+
+
+    procedure Marshal
+           (This : in out Proxy;
+            Op   : in     Opcode;
+            Args : in     Argument_Array);
+
+    function Marshal_Constructor
+           (This         : in out Proxy;
+            My_Interface : in     Protocol_Interface;
+            Op           : in     Opcode;
+            Args         : in     Argument_Array)
+        return Proxy;
+
+    function Marshal_Constructor
+           (This         : in out Proxy;
+            My_Interface : in     Protocol_Interface;
+            Op           : in     Opcode;
+            Args         : in     Argument_Array;
+            Version      : in     Version_Number)
+        return Proxy;
+
+
+    procedure Set_Dispatcher
+           (This : in out Proxy;
+            Func : in     Dispatcher_Function) is
+    begin
+        This.Current_Dispatcher := Func;
+    end Set_Dispatcher;
+
+
+    function Get_Version
+           (This : in Proxy)
+        return Version_Number is
+    begin
+        return Version_Number (wl_proxy_get_version (This.Void_Ptr));
+    end Get_Version;
+
+
+    function Get_ID
+           (This : in Proxy)
+        return ID_Number is
+    begin
+        return ID_Number (wl_proxy_get_id (This.Void_Ptr));
+    end Get_ID;
+
+
+    function Get_Interface_Name
+           (This : in Proxy)
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (wl_proxy_get_class (This.Void_Ptr));
+    end Get_Interfaces_Name;
+
+
+    procedure Set_Queue
+           (This  : in out Proxy;
+            Queue : in     Event_Queue_Access) is
+    begin
+        if Queue = null then
+            wl_proxy_set_queue (This.Void_Ptr, System.Null_Address);
+        else
+            wl_proxy_set_queue (This.Void_Ptr, Queue.Void_Ptr);
+        end if;
+    end Set_Queue;
+
+
+
+
+
+    --  Display
+
+    function Connect
+           (Name : in String)
+        return Display
+    is
+        Ptr : System.Address :=
+            wl_display_connect (Interfaces.C.To_C (Name));
+    begin
+        if Ptr = System.Null_Address then
+            raise Storage_Error;
+        end if;
+
+        return This : Display do
+            This.Void_Ptr := Ptr;
+            This.Current_Dispatcher := null;
+        end return;
+    end Connect;
+
+
+    function Connect_To_FD
+           (FD : in File_Descriptor)
+        return Display
+    is
+        Ptr : System.Address :=
+            wl_display_connect_to_fd (Interfaces.C.int (FD));
+    begin
+        if Ptr = System.Null_Address then
+            raise Storage_Error;
+        end if;
+
+        return This : Display do
+            This.Void_Ptr := Ptr;
+            This.Current_Dispatcher := null;
+        end return;
+    end Connect_To_FD;
+
+
+    function Get_FD
+           (This : in Display)
+        return File_Descriptor is
+    begin
+        return File_Descriptor (wl_display_get_fd (This.Void_Ptr));
+    end Get_FD;
+
+
+    function Dispatch
+           (This : in out Display)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched (wl_display_dispatch (This.Void_Ptr));
+    end Dispatch;
+
+
+    function Dispatch_Pending
+           (This : in out Display)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched (wl_display_dispatch_pending (This.Void_Ptr));
+    end Dispatch_Pending;
+
+
+    function Dispatch_Queue
+           (This  : in out Display;
+            Queue : in out Event_Queue)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched
+            (wl_display_dispatch_queue (This.Void_Ptr, Queue.Void_Ptr));
+    end Dispatch_Queue;
+
+
+    function Dispatch_Queue_Pending
+           (This  : in out Display;
+            Queue : in out Event_Queue)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched
+            (wl_display_dispatch_queue_pending (This.Void_Ptr, Queue.Void_Ptr));
+    end Dispatch_Queue_Pending;
+
+
+    function Get_Error
+           (This : in out Display)
+        return Error_Value is
+    begin
+        return Error_Value (wl_display_get_error (This.Void_Ptr));
+    end Get_Error;
+
+
+    function Get_Protocol_Error
+           (This         : in Display;
+            My_Interface : in Protocol_Interface_Access;
+            ID           : in ID_Number)
+        return Error_Value is
+    begin
+        return Error_Value
+            (wl_display_get_protocol_error
+                (This.Void_Ptr, My_Interfaces.Void_Ptr, Interfaces.C.unsigned (ID)));
+    end Get_Protocol_Error;
+
+
+    function Flush
+           (This : in out Display)
+        return Num_Bytes_Sent is
+    begin
+        return Num_Bytes_Sent (wl_display_flush (This.Void_Ptr));
+    end Flush;
+
+
+    function Roundtrip_Queue
+           (This  : in out Display;
+            Queue : in out Event_Queue)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched
+            (wl_display_roundtrip_queue (This.Void_Ptr, Queue.Void_Ptr));
+    end Roundtrip_Queue;
+
+
+    function Roundtrip
+           (This : in out Display)
+        return Num_Events_Dispatched is
+    begin
+        return Num_Events_Dispatched (wl_display_roundtrip (This.Void_Ptr));
+    end Roundtrip;
+
+
+    procedure Read_Events
+           (This  : in out Display) is
+    begin
+        if  wl_display_prepare_read (This.Void_Ptr) /= 0 or else
+            wl_display_read_events (This.Void_Ptr) /= 0
+        then
+            raise Wayland_Error;
+        end if;
+    end Read_Events;
+
+
+    procedure Read_Events
+           (This  : in out Display;
+            Queue : in out Event_Queue) is
+    begin
+        if  wl_display_prepare_read_queue (This.Void_Ptr, Queue.Void_Ptr) /= 0 or else
+            wl_display_read_events (This.Void_Ptr) /= 0
+        then
+            raise Wayland_Error;
+        end if;
+    end Read_Events;
+
+
+
+
+
+    --  Event_Queue
+
+    function Create_Queue
+           (This : in out Display)
+        return Event_Queue
+    is
+        Ptr : System.Address :=
+            wl_display_create_queue (This.Void_Ptr);
+    begin
+        if Ptr = System.Null_Address then
+            raise Storage_Error;
+        end if;
+
+        return Queue : Event_Queue do
+            Queue.Void_Ptr := Ptr;
+        end return;
+    end Create_Queue;
+
+
+
+
+
+    --  Log
+
+    procedure Set_Log_Handler
+           (Handler : in Log_Function) is
+    begin
+        Current_Log_Function := Handler;
+    end Set_Log_Handler;
+
+
+
+
+begin
+
+
+    wayland_client_set_log_hook (Log_Function_Hook'Access);
+
+
+end Wayland.Client;
+
diff --git a/src/wayland-client.ads b/src/wayland-client.ads
index 2d6fff0..d206227 100644
--- a/src/wayland-client.ads
+++ b/src/wayland-client.ads
@@ -1,5 +1,10 @@
 
 
+private with
+
+    System.Address_To_Access_Conversions;
+
+
 package Wayland.Client is
 
 
@@ -24,8 +29,9 @@ package Wayland.Client is
 
 
     type Dispatcher_Function is access procedure
-           (Obj : in Wayland_Object;
-            Op  : in Opcode);
+           (Obj  : in out Proxy;
+            Op   : in     Opcode;
+            Args : in     Argument_Array);
 
 
 
@@ -57,20 +63,6 @@ package Wayland.Client is
             Version      : in     Version_Number)
         return Proxy;
 
-    procedure Add_Listener
-           (This : in out Proxy;
-            Op   : in     Opcode;
-            Func : in     Listener_Function);
-
-    function Get_Listener
-           (This : in Proxy;
-            Op   : in Opcode)
-        return Listener_Function;
-
-    procedure Remove_Listener
-           (This : in out Proxy;
-            Op   : in     Opcode);
-
     procedure Set_Dispatcher
            (This : in out Proxy;
             Func : in     Dispatcher_Function);
@@ -104,9 +96,6 @@ package Wayland.Client is
            (FD : in File_Descriptor)
         return Display;
 
-    procedure Disconnect
-           (This : in out Display);
-
     function Get_FD
            (This : in Display)
         return File_Descriptor;
@@ -180,11 +169,15 @@ package Wayland.Client is
 private
 
 
-    type Proxy is new Wayland_Object with null record;
+    type Proxy is new Wayland_Object with record
+        Current_Dispatcher : Dispatcher_Function;
+    end record;
 
     procedure Finalize
            (This : in out Proxy);
 
+    package Proxy_Convert is new System.Address_To_Access_Conversions (Proxy'Class);
+
 
 
 
diff --git a/src/wayland.adb b/src/wayland.adb
new file mode 100644
index 0000000..db232c6
--- /dev/null
+++ b/src/wayland.adb
@@ -0,0 +1,57 @@
+
+
+package body Wayland is
+
+
+    function Arg
+           (Of_Type : in Unsigned_Integer)
+        return Arg (Uint);
+
+
+    function Arg
+           (Of_Type : in Integer)
+        return Arg (Int);
+
+
+    function Arg
+           (Of_Type : in )
+        return Arg (Fixed);
+
+
+    function Arg
+           (Of_Type : in String)
+        return Arg (String);
+
+
+    function Arg
+           (Of_Type : in )
+        return Arg (Arr);
+
+
+    function Arg
+           (Of_Type : in File_Descriptor)
+        return Arg (FD);
+
+
+    function Arg
+           (Of_Type : in ID_Number)
+        return Arg (ID);
+
+
+    function Arg
+           (Of_Type : in )
+        return Arg (Obj);
+
+
+
+
+
+    procedure Initialize
+           (This : in out Wayland_Object) is
+    begin
+        This.Void_Ptr := System.Null_Address;
+    end Initialize;
+
+
+end Wayland;
+
diff --git a/src/wayland.ads b/src/wayland.ads
index bfab18d..6c10b1c 100644
--- a/src/wayland.ads
+++ b/src/wayland.ads
@@ -9,6 +9,11 @@ private with
 package Wayland is
 
 
+    Wayland_Error : exception;
+
+
+
+
     type Unsigned_Integer is mod 2 ** 32;
 
     type Result is (Success, Failure);
@@ -92,8 +97,15 @@ package Wayland is
 private
 
 
+    type Argument (Kind : Argument_Kind) is record
+        
+    end record;
+
+
+
+
     type Wayland_Object is new Ada.Finalization.Limited_Controlled with record
-        Void_Ptr : System.Address := System.Null_Address;
+        Void_Ptr : System.Address;
     end record;
 
     procedure Initialize