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;