From 0b86daff6bc58119f2b0ad5324fd18857dfdb3c5 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Tue, 2 Jan 2018 21:05:54 +1100 Subject: Update from before Christmas --- src/c_wayland_client.c | 45 ++++ src/c_wayland_client.h | 14 ++ src/wayland-client.adb | 544 +++++++++++++++++++++++++++++++++++++++++++++++++ src/wayland-client.ads | 33 ++- src/wayland.adb | 57 ++++++ src/wayland.ads | 14 +- 6 files changed, 686 insertions(+), 21 deletions(-) create mode 100644 src/c_wayland_client.c create mode 100644 src/c_wayland_client.h create mode 100644 src/wayland-client.adb create mode 100644 src/wayland.adb 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 +#include +#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 -- cgit