diff options
Diffstat (limited to 'body/fltk-menu_items.adb')
| -rw-r--r-- | body/fltk-menu_items.adb | 604 |
1 files changed, 604 insertions, 0 deletions
diff --git a/body/fltk-menu_items.adb b/body/fltk-menu_items.adb new file mode 100644 index 0000000..d68eb60 --- /dev/null +++ b/body/fltk-menu_items.adb @@ -0,0 +1,604 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widget_Callback_Conversions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Menu_Items is + + + package Callback_Convert renames FLTK.Widget_Callback_Conversions; + + + + + function new_fl_menu_item + (T : in Interfaces.C.char_array; + C : in Storage.Integer_Address; + S, F : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_menu_item, "new_fl_menu_item"); + pragma Inline (new_fl_menu_item); + + procedure free_fl_menu_item + (MI : in Storage.Integer_Address); + pragma Import (C, free_fl_menu_item, "free_fl_menu_item"); + pragma Inline (free_fl_menu_item); + + + + + function fl_menu_item_get_user_data + (MI : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_menu_item_get_user_data, "fl_menu_item_get_user_data"); + pragma Inline (fl_menu_item_get_user_data); + + procedure fl_menu_item_set_callback + (MI, C : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_set_callback, "fl_menu_item_set_callback"); + pragma Inline (fl_menu_item_set_callback); + + procedure fl_menu_item_do_callback + (MI, W : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_do_callback, "fl_menu_item_do_callback"); + pragma Inline (fl_menu_item_do_callback); + + + + + function fl_menu_item_checkbox + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_checkbox, "fl_menu_item_checkbox"); + pragma Inline (fl_menu_item_checkbox); + + function fl_menu_item_radio + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_radio, "fl_menu_item_radio"); + pragma Inline (fl_menu_item_radio); + + function fl_menu_item_submenu + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_submenu, "fl_menu_item_submenu"); + pragma Inline (fl_menu_item_submenu); + + function fl_menu_item_value + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_value, "fl_menu_item_value"); + pragma Inline (fl_menu_item_value); + + procedure fl_menu_item_set + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_set, "fl_menu_item_set"); + pragma Inline (fl_menu_item_set); + + procedure fl_menu_item_clear + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_clear, "fl_menu_item_clear"); + pragma Inline (fl_menu_item_clear); + + procedure fl_menu_item_setonly + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_setonly, "fl_menu_item_setonly"); + pragma Inline (fl_menu_item_setonly); + + + + + function fl_menu_item_get_label + (MI : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_menu_item_get_label, "fl_menu_item_get_label"); + pragma Inline (fl_menu_item_get_label); + + procedure fl_menu_item_set_label + (MI : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_item_set_label, "fl_menu_item_set_label"); + pragma Inline (fl_menu_item_set_label); + + procedure fl_menu_item_set_label2 + (MI : in Storage.Integer_Address; + K : in Interfaces.C.int; + T : in Interfaces.C.char_array); + pragma Import (C, fl_menu_item_set_label2, "fl_menu_item_set_label2"); + pragma Inline (fl_menu_item_set_label2); + + function fl_menu_item_get_labelcolor + (MI : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_menu_item_get_labelcolor, "fl_menu_item_get_labelcolor"); + pragma Inline (fl_menu_item_get_labelcolor); + + procedure fl_menu_item_set_labelcolor + (MI : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_menu_item_set_labelcolor, "fl_menu_item_set_labelcolor"); + pragma Inline (fl_menu_item_set_labelcolor); + + function fl_menu_item_get_labelfont + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labelfont, "fl_menu_item_get_labelfont"); + pragma Inline (fl_menu_item_get_labelfont); + + procedure fl_menu_item_set_labelfont + (MI : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labelfont, "fl_menu_item_set_labelfont"); + pragma Inline (fl_menu_item_set_labelfont); + + function fl_menu_item_get_labelsize + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labelsize, "fl_menu_item_get_labelsize"); + pragma Inline (fl_menu_item_get_labelsize); + + procedure fl_menu_item_set_labelsize + (MI : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labelsize, "fl_menu_item_set_labelsize"); + pragma Inline (fl_menu_item_set_labelsize); + + function fl_menu_item_get_labeltype + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_labeltype, "fl_menu_item_get_labeltype"); + pragma Inline (fl_menu_item_get_labeltype); + + procedure fl_menu_item_set_labeltype + (MI : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_labeltype, "fl_menu_item_set_labeltype"); + pragma Inline (fl_menu_item_set_labeltype); + + + + + function fl_menu_item_get_shortcut + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_shortcut, "fl_menu_item_get_shortcut"); + pragma Inline (fl_menu_item_get_shortcut); + + procedure fl_menu_item_set_shortcut + (MI : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_shortcut, "fl_menu_item_set_shortcut"); + pragma Inline (fl_menu_item_set_shortcut); + + function fl_menu_item_get_flags + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_get_flags, "fl_menu_item_get_flags"); + pragma Inline (fl_menu_item_get_flags); + + procedure fl_menu_item_set_flags + (MI : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_menu_item_set_flags, "fl_menu_item_set_flags"); + pragma Inline (fl_menu_item_set_flags); + + + + + procedure fl_menu_item_image + (MI, I : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_image, "fl_menu_item_image"); + pragma Inline (fl_menu_item_image); + + + + + procedure fl_menu_item_activate + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_activate, "fl_menu_item_activate"); + pragma Inline (fl_menu_item_activate); + + procedure fl_menu_item_deactivate + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_deactivate, "fl_menu_item_deactivate"); + pragma Inline (fl_menu_item_deactivate); + + procedure fl_menu_item_show + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_show, "fl_menu_item_show"); + pragma Inline (fl_menu_item_show); + + procedure fl_menu_item_hide + (MI : in Storage.Integer_Address); + pragma Import (C, fl_menu_item_hide, "fl_menu_item_hide"); + pragma Inline (fl_menu_item_hide); + + function fl_menu_item_active + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_active, "fl_menu_item_active"); + pragma Inline (fl_menu_item_active); + + function fl_menu_item_visible + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_visible, "fl_menu_item_visible"); + pragma Inline (fl_menu_item_visible); + + function fl_menu_item_activevisible + (MI : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_menu_item_activevisible, "fl_menu_item_activevisible"); + pragma Inline (fl_menu_item_activevisible); + + + + + procedure Finalize + (This : in out Menu_Item) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_menu_item (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + (Text : in String; + Action : in FLTK.Widgets.Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Menu_Item is + begin + return This : Menu_Item do + This.Void_Ptr := new_fl_menu_item + (Interfaces.C.To_C (Text), + Callback_Convert.To_Address (Action), + To_C (Shortcut), + Interfaces.C.int (Flags)); + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + function Get_Callback + (This : in Menu_Item) + return FLTK.Widgets.Widget_Callback is + begin + return Callback_Convert.To_Access (fl_menu_item_get_user_data (This.Void_Ptr)); + end Get_Callback; + + + procedure Set_Callback + (This : in out Menu_Item; + Func : in FLTK.Widgets.Widget_Callback) is + begin + -- Coordinating callback vs userdata is done in C++ + fl_menu_item_set_callback + (This.Void_Ptr, + Callback_Convert.To_Address (Func)); + end Set_Callback; + + + procedure Do_Callback + (This : in out Menu_Item; + Widget : in out FLTK.Widgets.Widget'Class) is + begin + fl_menu_item_do_callback (This.Void_Ptr, Wrapper (Widget).Void_Ptr); + end Do_Callback; + + + + + function Has_Checkbox + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_checkbox (This.Void_Ptr) /= 0; + end Has_Checkbox; + + + function Is_Radio + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_radio (This.Void_Ptr) /= 0; + end Is_Radio; + + + function Is_Submenu + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_submenu (This.Void_Ptr) /= 0; + end Is_Submenu; + + + function Get_State + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_value (This.Void_Ptr) /= 0; + end Get_State; + + + procedure Set_State + (This : in out Menu_Item; + To : in Boolean) is + begin + if To then + fl_menu_item_set (This.Void_Ptr); + else + fl_menu_item_clear (This.Void_Ptr); + end if; + end Set_State; + + + procedure Set + (This : in out Menu_Item) is + begin + fl_menu_item_set (This.Void_Ptr); + end Set; + + + procedure Clear + (This : in out Menu_Item) is + begin + fl_menu_item_clear (This.Void_Ptr); + end Clear; + + + procedure Set_Only + (This : in out Menu_Item) is + begin + fl_menu_item_setonly (This.Void_Ptr); + end Set_Only; + + + + + function Get_Label + (This : in Menu_Item) + return String + is + Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); + begin + if Ptr = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Ptr); + end if; + end Get_Label; + + + procedure Set_Label + (This : in out Menu_Item; + Text : in String) is + begin + fl_menu_item_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end Set_Label; + + + procedure Set_Label + (This : in out Menu_Item; + Kind : in Label_Kind; + Text : in String) is + begin + fl_menu_item_set_label2 (This.Void_Ptr, Label_Kind'Pos (Kind), Interfaces.C.To_C (Text)); + end Set_Label; + + + function Get_Label_Color + (This : in Menu_Item) + return Color is + begin + return Color (fl_menu_item_get_labelcolor (This.Void_Ptr)); + end Get_Label_Color; + + + procedure Set_Label_Color + (This : in out Menu_Item; + To : in Color) is + begin + fl_menu_item_set_labelcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); + end Set_Label_Color; + + + function Get_Label_Font + (This : in Menu_Item) + return Font_Kind + is + Result : Interfaces.C.int := fl_menu_item_get_labelfont (This.Void_Ptr); + begin + return Font_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelfont returned unexpected Font value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Font; + + + procedure Set_Label_Font + (This : in out Menu_Item; + To : in Font_Kind) is + begin + fl_menu_item_set_labelfont (This.Void_Ptr, Font_Kind'Pos (To)); + end Set_Label_Font; + + + function Get_Label_Size + (This : in Menu_Item) + return Font_Size + is + Result : Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); + begin + return Font_Size (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labelsize returned unexpected Size value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Size; + + + procedure Set_Label_Size + (This : in out Menu_Item; + To : in Font_Size) is + begin + fl_menu_item_set_labelsize (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Label_Size; + + + function Get_Label_Kind + (This : in Menu_Item) + return Label_Kind + is + Result : Interfaces.C.int := fl_menu_item_get_labeltype (This.Void_Ptr); + begin + return Label_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "Fl_Menu_Item::labeltype returned unexpected Kind value of " & + Interfaces.C.int'Image (Result); + end Get_Label_Kind; + + + procedure Set_Label_Kind + (This : in out Menu_Item; + To : in Label_Kind) is + begin + fl_menu_item_set_labeltype (This.Void_Ptr, Label_Kind'Pos (To)); + end Set_Label_Kind; + + + + + function Get_Shortcut + (This : in Menu_Item) + return Key_Combo is + begin + return To_Ada (fl_menu_item_get_shortcut (This.Void_Ptr)); + end Get_Shortcut; + + + procedure Set_Shortcut + (This : in out Menu_Item; + To : in Key_Combo) is + begin + fl_menu_item_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); + end Set_Shortcut; + + + function Get_Flags + (This : in Menu_Item) + return Menu_Flag is + begin + return Menu_Flag (fl_menu_item_get_flags (This.Void_Ptr)); + end Get_Flags; + + + procedure Set_Flags + (This : in out Menu_Item; + To : in Menu_Flag) is + begin + fl_menu_item_set_flags (This.Void_Ptr, Interfaces.C.int (To)); + end Set_Flags; + + + + + function Get_Image + (This : in Menu_Item) + return access FLTK.Images.Image'Class is + begin + return This.Current_Image; + end Get_Image; + + + procedure Set_Image + (This : in out Menu_Item; + Pict : in out FLTK.Images.Image'Class) is + begin + fl_menu_item_image (This.Void_Ptr, Wrapper (Pict).Void_Ptr); + This.Current_Image := Pict'Unchecked_Access; + end Set_Image; + + + + + procedure Activate + (This : in out Menu_Item) is + begin + fl_menu_item_activate (This.Void_Ptr); + end Activate; + + + procedure Deactivate + (This : in out Menu_Item) is + begin + fl_menu_item_deactivate (This.Void_Ptr); + end Deactivate; + + + procedure Show + (This : in out Menu_Item) is + begin + fl_menu_item_show (This.Void_Ptr); + end Show; + + + procedure Hide + (This : in out Menu_Item) is + begin + fl_menu_item_hide (This.Void_Ptr); + end Hide; + + + function Is_Active + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_active (This.Void_Ptr) /= 0; + end Is_Active; + + + function Is_Visible + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_visible (This.Void_Ptr) /= 0; + end Is_Visible; + + + function Is_Active_And_Visible + (This : in Menu_Item) + return Boolean is + begin + return fl_menu_item_activevisible (This.Void_Ptr) /= 0; + end Is_Active_And_Visible; + + +end FLTK.Menu_Items; + + |