with Interfaces.C.Strings, System; use type Interfaces.C.int, Interfaces.C.Strings.chars_ptr, System.Address; package body FLTK.Event is procedure fl_event_add_handler (F : in System.Address); pragma Import (C, fl_event_add_handler, "fl_event_add_handler"); pragma Inline (fl_event_add_handler); procedure fl_event_set_event_dispatch (F : in System.Address); pragma Import (C, fl_event_set_event_dispatch, "fl_event_set_event_dispatch"); pragma Inline (fl_event_set_event_dispatch); -- actually handle_ but can't have an underscore on the end of an identifier function fl_event_handle (E : in Interfaces.C.int; W : in System.Address) return Interfaces.C.int; pragma Import (C, fl_event_handle, "fl_event_handle"); pragma Inline (fl_event_handle); function fl_event_get_grab return System.Address; pragma Import (C, fl_event_get_grab, "fl_event_get_grab"); pragma Inline (fl_event_get_grab); procedure fl_event_set_grab (T : in System.Address); pragma Import (C, fl_event_set_grab, "fl_event_set_grab"); pragma Inline (fl_event_set_grab); function fl_event_get_pushed return System.Address; pragma Import (C, fl_event_get_pushed, "fl_event_get_pushed"); pragma Inline (fl_event_get_pushed); procedure fl_event_set_pushed (T : in System.Address); pragma Import (C, fl_event_set_pushed, "fl_event_set_pushed"); pragma Inline (fl_event_set_pushed); function fl_event_get_belowmouse return System.Address; pragma Import (C, fl_event_get_belowmouse, "fl_event_get_belowmouse"); pragma Inline (fl_event_get_belowmouse); procedure fl_event_set_belowmouse (T : in System.Address); pragma Import (C, fl_event_set_belowmouse, "fl_event_set_belowmouse"); pragma Inline (fl_event_set_belowmouse); function fl_event_get_focus return System.Address; pragma Import (C, fl_event_get_focus, "fl_event_get_focus"); pragma Inline (fl_event_get_focus); procedure fl_event_set_focus (To : in System.Address); pragma Import (C, fl_event_set_focus, "fl_event_set_focus"); pragma Inline (fl_event_set_focus); function fl_event_compose (D : out Interfaces.C.int) return Interfaces.C.int; pragma Import (C, fl_event_compose, "fl_event_compose"); pragma Inline (fl_event_compose); procedure fl_event_compose_reset; pragma Import (C, fl_event_compose_reset, "fl_event_compose_reset"); pragma Inline (fl_event_compose_reset); function fl_event_text return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_event_text, "fl_event_text"); pragma Inline (fl_event_text); function fl_event_length return Interfaces.C.int; pragma Import (C, fl_event_length, "fl_event_length"); pragma Inline (fl_event_length); function fl_event_get return Interfaces.C.int; pragma Import (C, fl_event_get, "fl_event_get"); pragma Inline (fl_event_get); function fl_event_state return Interfaces.C.unsigned_long; pragma Import (C, fl_event_state, "fl_event_state"); pragma Inline (fl_event_state); function fl_event_check_state (S : in Interfaces.C.unsigned_long) return Interfaces.C.int; pragma Import (C, fl_event_check_state, "fl_event_check_state"); pragma Inline (fl_event_check_state); function fl_event_x return Interfaces.C.int; pragma Import (C, fl_event_x, "fl_event_x"); pragma Inline (fl_event_x); function fl_event_x_root return Interfaces.C.int; pragma Import (C, fl_event_x_root, "fl_event_x_root"); pragma Inline (fl_event_x_root); function fl_event_y return Interfaces.C.int; pragma Import (C, fl_event_y, "fl_event_y"); pragma Inline (fl_event_y); function fl_event_y_root return Interfaces.C.int; pragma Import (C, fl_event_y_root, "fl_event_y_root"); pragma Inline (fl_event_y_root); function fl_event_dx return Interfaces.C.int; pragma Import (C, fl_event_dx, "fl_event_dx"); pragma Inline (fl_event_dx); function fl_event_dy return Interfaces.C.int; pragma Import (C, fl_event_dy, "fl_event_dy"); pragma Inline (fl_event_dy); procedure fl_event_get_mouse (X, Y : out Interfaces.C.int); pragma Import (C, fl_event_get_mouse, "fl_event_get_mouse"); pragma Inline (fl_event_get_mouse); function fl_event_is_click return Interfaces.C.int; pragma Import (C, fl_event_is_click, "fl_event_is_click"); pragma Inline (fl_event_is_click); function fl_event_is_clicks return Interfaces.C.int; pragma Import (C, fl_event_is_clicks, "fl_event_is_clicks"); pragma Inline (fl_event_is_clicks); procedure fl_event_set_clicks (C : in Interfaces.C.int); pragma Import (C, fl_event_set_clicks, "fl_event_set_clicks"); pragma Inline (fl_event_set_clicks); function fl_event_button return Interfaces.C.int; pragma Import (C, fl_event_button, "fl_event_button"); pragma Inline (fl_event_button); function fl_event_button1 return Interfaces.C.int; pragma Import (C, fl_event_button1, "fl_event_button1"); pragma Inline (fl_event_button1); function fl_event_button2 return Interfaces.C.int; pragma Import (C, fl_event_button2, "fl_event_button2"); pragma Inline (fl_event_button2); function fl_event_button3 return Interfaces.C.int; pragma Import (C, fl_event_button3, "fl_event_button3"); pragma Inline (fl_event_button3); function fl_event_inside (X, Y, W, H : in Interfaces.C.int) return Interfaces.C.int; pragma Import (C, fl_event_inside, "fl_event_inside"); pragma Inline (fl_event_inside); function fl_event_key return Interfaces.C.unsigned_long; pragma Import (C, fl_event_key, "fl_event_key"); pragma Inline (fl_event_key); function fl_event_original_key return Interfaces.C.unsigned_long; pragma Import (C, fl_event_original_key, "fl_event_original_key"); pragma Inline (fl_event_original_key); function fl_event_key_during (K : in Interfaces.C.unsigned_long) return Interfaces.C.int; pragma Import (C, fl_event_key_during, "fl_event_key_during"); pragma Inline (fl_event_key_during); function fl_event_get_key (K : in Interfaces.C.unsigned_long) return Interfaces.C.int; pragma Import (C, fl_event_get_key, "fl_event_get_key"); pragma Inline (fl_event_get_key); function fl_event_ctrl return Interfaces.C.int; pragma Import (C, fl_event_ctrl, "fl_event_ctrl"); pragma Inline (fl_event_ctrl); function fl_event_alt return Interfaces.C.int; pragma Import (C, fl_event_alt, "fl_event_alt"); pragma Inline (fl_event_alt); function fl_event_command return Interfaces.C.int; pragma Import (C, fl_event_command, "fl_event_command"); pragma Inline (fl_event_command); function fl_event_shift return Interfaces.C.int; pragma Import (C, fl_event_shift, "fl_event_shift"); pragma Inline (fl_event_shift); function Event_Handler_Hook (Num : in Interfaces.C.int) return Interfaces.C.int is Ret_Val : Event_Outcome; begin for Func of reverse Handlers loop Ret_Val := Func (Event_Kind'Val (Num)); if Ret_Val /= Not_Handled then return Event_Outcome'Pos (Ret_Val); end if; end loop; return Event_Outcome'Pos (Not_Handled); end Event_Handler_Hook; -- function Dispatch_Hook -- (Num : in Interfaces.C.int; -- Ptr : in System.Address) -- return Interfaces.C.int -- is -- Ret_Val : Event_Outcome; -- Actual_Window : access FLTK.Widgets.Groups.Windows.Window'Class; -- begin -- if Ptr /= System.Null_Address then -- Actual_Window := Window_Convert.To_Pointer (fl_widget_get_user_data (Ptr)); -- end if; -- if Current_Dispatch = null then -- Ret_Val := Default_Dispatch (Event_Kind'Val (Num), Actual_Window); -- else -- Ret_Val := Current_Dispatch (Event_Kind'Val (Num), Actual_Window); -- end if; -- return Event_Outcome'Pos (Ret_Val); -- end Dispatch_Hook; procedure Add_Handler (Func : in Event_Handler) is begin Handlers.Append (Func); end Add_Handler; procedure Remove_Handler (Func : in Event_Handler) is begin for I in reverse Handlers.First_Index .. Handlers.Last_Index loop if Handlers (I) = Func then Handlers.Delete (I); return; end if; end loop; end Remove_Handler; -- function Get_Dispatch -- return Event_Dispatch is -- begin -- if Current_Dispatch = null then -- return Default_Dispatch'Access; -- else -- return Current_Dispatch; -- end if; -- end Get_Dispatch; -- procedure Set_Dispatch -- (Func : in Event_Dispatch) is -- begin -- Current_Dispatch := Func; -- end Set_Dispatch; -- function Default_Dispatch -- (Event : in Event_Kind; -- Win : access FLTK.Widgets.Groups.Windows.Window'Class) -- return Event_Outcome is -- begin -- if Win = null then -- return Event_Outcome'Val (fl_event_handle -- (Event_Kind'Pos (Event), System.Null_Address)); -- else -- return Event_Outcome'Val (fl_event_handle -- (Event_Kind'Pos (Event), -- Wrapper (Win.all).Void_Ptr)); -- end if; -- end Default_Dispatch; function Get_Grab return access FLTK.Widgets.Groups.Windows.Window'Class is begin return Window_Convert.To_Pointer (fl_widget_get_user_data (fl_event_get_grab)); end Get_Grab; procedure Set_Grab (To : in FLTK.Widgets.Groups.Windows.Window'Class) is begin fl_event_set_grab (Wrapper (To).Void_Ptr); end Set_Grab; procedure Release_Grab is begin fl_event_set_grab (System.Null_Address); end Release_Grab; function Get_Pushed return access FLTK.Widgets.Widget'Class is begin return Widget_Convert.To_Pointer (fl_widget_get_user_data (fl_event_get_pushed)); end Get_Pushed; procedure Set_Pushed (To : in FLTK.Widgets.Widget'Class) is begin fl_event_set_pushed (Wrapper (To).Void_Ptr); end Set_Pushed; function Get_Below_Mouse return access FLTK.Widgets.Widget'Class is begin return Widget_Convert.To_Pointer (fl_widget_get_user_data (fl_event_get_belowmouse)); end Get_Below_Mouse; procedure Set_Below_Mouse (To : in FLTK.Widgets.Widget'Class) is begin fl_event_set_belowmouse (Wrapper (To).Void_Ptr); end Set_Below_Mouse; function Get_Focus return access FLTK.Widgets.Widget'Class is begin return Widget_Convert.To_Pointer (fl_widget_get_user_data (fl_event_get_focus)); end Get_Focus; procedure Set_Focus (To : in FLTK.Widgets.Widget'Class) is begin fl_event_set_focus (Wrapper (To).Void_Ptr); end Set_Focus; function Compose (Del : out Natural) return Boolean is begin return fl_event_compose (Interfaces.C.int (Del)) /= 0; end Compose; procedure Compose_Reset is begin fl_event_compose_reset; end Compose_Reset; function Text return String is Str : Interfaces.C.Strings.chars_ptr := fl_event_text; begin if Str = Interfaces.C.Strings.Null_Ptr then return ""; else return Interfaces.C.Strings.Value (Str, Interfaces.C.size_t (fl_event_length)); end if; end Text; function Text_Length return Natural is begin return Natural (fl_event_length); end Text_Length; function Last return Event_Kind is begin return Event_Kind'Val (fl_event_get); end Last; function Last_Modifier return Modifier is begin return To_Ada (fl_event_state); end Last_Modifier; function Last_Modifier (Had : in Modifier) return Boolean is begin return fl_event_check_state (To_C (Had)) /= 0; end Last_Modifier; function Mouse_X return Integer is begin return Integer (fl_event_x); end Mouse_X; function Mouse_X_Root return Integer is begin return Integer (fl_event_x_root); end Mouse_X_Root; function Mouse_Y return Integer is begin return Integer (fl_event_y); end Mouse_Y; function Mouse_Y_Root return Integer is begin return Integer (fl_event_y_root); end Mouse_Y_Root; function Mouse_DX return Integer is begin return Integer (fl_event_dx); end Mouse_DX; function Mouse_DY return Integer is begin return Integer (fl_event_dy); end Mouse_DY; procedure Get_Mouse (X, Y : out Integer) is begin fl_event_get_mouse (Interfaces.C.int (X), Interfaces.C.int (Y)); end Get_Mouse; function Is_Click return Boolean is begin return fl_event_is_click /= 0; end Is_Click; function Is_Multi_Click return Boolean is begin return fl_event_is_clicks /= 0; end Is_Multi_Click; procedure Set_Clicks (To : in Natural) is begin fl_event_set_clicks (Interfaces.C.int (To)); end Set_Clicks; function Last_Button return Mouse_Button is begin return Mouse_Button'Val (fl_event_button); end Last_Button; function Mouse_Left return Boolean is begin return fl_event_button1 /= 0; end Mouse_Left; function Mouse_Middle return Boolean is begin return fl_event_button2 /= 0; end Mouse_Middle; function Mouse_Right return Boolean is begin return fl_event_button3 /= 0; end Mouse_Right; function Is_Inside (X, Y, W, H : in Integer) return Boolean is begin return fl_event_inside (Interfaces.C.int (X), Interfaces.C.int (Y), Interfaces.C.int (W), Interfaces.C.int (H)) /= 0; end Is_Inside; function Last_Key return Keypress is begin return To_Ada (fl_event_key); end Last_Key; function Original_Last_Key return Keypress is begin return To_Ada (fl_event_original_key); end Original_Last_Key; function Pressed_During (Key : in Keypress) return Boolean is begin return fl_event_key_during (To_C (Key)) /= 0; end Pressed_During; function Key_Now (Key : in Keypress) return Boolean is begin return fl_event_get_key (To_C (Key)) /= 0; end Key_Now; function Key_Ctrl return Boolean is begin return fl_event_ctrl /= 0; end Key_Ctrl; function Key_Alt return Boolean is begin return fl_event_alt /= 0; end Key_Alt; function Key_Command return Boolean is begin return fl_event_command /= 0; end Key_Command; function Key_Shift return Boolean is begin return fl_event_shift /= 0; end Key_Shift; begin fl_event_add_handler (Event_Handler_Hook'Address); -- fl_event_set_event_dispatch (Dispatch_Hook'Address); end FLTK.Event;