diff options
Diffstat (limited to 'src/fltk-menu_items.adb')
| -rw-r--r-- | src/fltk-menu_items.adb | 241 |
1 files changed, 173 insertions, 68 deletions
diff --git a/src/fltk-menu_items.adb b/src/fltk-menu_items.adb index b93f1f5..2acaeeb 100644 --- a/src/fltk-menu_items.adb +++ b/src/fltk-menu_items.adb @@ -45,10 +45,10 @@ package body FLTK.Menu_Items is 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_user_data + procedure fl_menu_item_set_callback (MI, C : in Storage.Integer_Address); - pragma Import (C, fl_menu_item_set_user_data, "fl_menu_item_set_user_data"); - pragma Inline (fl_menu_item_set_user_data); + 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); @@ -70,6 +70,12 @@ package body FLTK.Menu_Items is 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; @@ -106,6 +112,13 @@ package body FLTK.Menu_Items is 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; @@ -184,6 +197,14 @@ package body FLTK.Menu_Items is + 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"); @@ -246,8 +267,8 @@ package body FLTK.Menu_Items is Flags : in Menu_Flag := Flag_Normal) return Menu_Item is begin - return Item : Menu_Item do - Item.Void_Ptr := new_fl_menu_item + 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), @@ -263,79 +284,106 @@ package body FLTK.Menu_Items is function Get_Callback - (Item : in Menu_Item) + (This : in Menu_Item) return FLTK.Widgets.Widget_Callback is begin - return Callback_Convert.To_Access (fl_menu_item_get_user_data (Item.Void_Ptr)); + return Callback_Convert.To_Access (fl_menu_item_get_user_data (This.Void_Ptr)); end Get_Callback; procedure Set_Callback - (Item : in out Menu_Item; + (This : in out Menu_Item; Func : in FLTK.Widgets.Widget_Callback) is begin - fl_menu_item_set_user_data - (Item.Void_Ptr, + -- 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 - (Item : in out Menu_Item; + (This : in out Menu_Item; Widget : in out FLTK.Widgets.Widget'Class) is begin - fl_menu_item_do_callback (Item.Void_Ptr, Wrapper (Widget).Void_Ptr); + fl_menu_item_do_callback (This.Void_Ptr, Wrapper (Widget).Void_Ptr); end Do_Callback; function Has_Checkbox - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_checkbox (Item.Void_Ptr) /= 0; + return fl_menu_item_checkbox (This.Void_Ptr) /= 0; end Has_Checkbox; + function Is_Radio - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_radio (Item.Void_Ptr) /= 0; + 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 - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_value (Item.Void_Ptr) /= 0; + return fl_menu_item_value (This.Void_Ptr) /= 0; end Get_State; + procedure Set_State - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Boolean) is begin if To then - fl_menu_item_set (Item.Void_Ptr); + fl_menu_item_set (This.Void_Ptr); else - fl_menu_item_clear (Item.Void_Ptr); + 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 - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_setonly (Item.Void_Ptr); + fl_menu_item_setonly (This.Void_Ptr); end Set_Only; function Get_Label - (Item : in Menu_Item) + (This : in Menu_Item) return String is - Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (Item.Void_Ptr); + Ptr : Interfaces.C.Strings.chars_ptr := fl_menu_item_get_label (This.Void_Ptr); begin if Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -344,156 +392,213 @@ package body FLTK.Menu_Items is end if; end Get_Label; + procedure Set_Label - (Item : in out Menu_Item; + (This : in out Menu_Item; Text : in String) is begin - fl_menu_item_set_label (Item.Void_Ptr, Interfaces.C.To_C (Text)); + 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 - (Item : in Menu_Item) + (This : in Menu_Item) return Color is begin - return Color (fl_menu_item_get_labelcolor (Item.Void_Ptr)); + return Color (fl_menu_item_get_labelcolor (This.Void_Ptr)); end Get_Label_Color; + procedure Set_Label_Color - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Color) is begin - fl_menu_item_set_labelcolor (Item.Void_Ptr, Interfaces.C.unsigned (To)); + fl_menu_item_set_labelcolor (This.Void_Ptr, Interfaces.C.unsigned (To)); end Set_Label_Color; + function Get_Label_Font - (Item : in Menu_Item) - return Font_Kind is + (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 (fl_menu_item_get_labelfont (Item.Void_Ptr)); + 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 - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Kind) is begin - fl_menu_item_set_labelfont (Item.Void_Ptr, Font_Kind'Pos (To)); + fl_menu_item_set_labelfont (This.Void_Ptr, Font_Kind'Pos (To)); end Set_Label_Font; + function Get_Label_Size - (Item : in Menu_Item) - return Font_Size is + (This : in Menu_Item) + return Font_Size + is + Result : Interfaces.C.int := fl_menu_item_get_labelsize (This.Void_Ptr); begin - return Font_Size (fl_menu_item_get_labelsize (Item.Void_Ptr)); + 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 - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Font_Size) is begin - fl_menu_item_set_labelsize (Item.Void_Ptr, Interfaces.C.int (To)); + fl_menu_item_set_labelsize (This.Void_Ptr, Interfaces.C.int (To)); end Set_Label_Size; + function Get_Label_Type - (Item : in Menu_Item) - return Label_Kind is + (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 (fl_menu_item_get_labeltype (Item.Void_Ptr)); + 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_Type; + procedure Set_Label_Type - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Label_Kind) is begin - fl_menu_item_set_labeltype (Item.Void_Ptr, Label_Kind'Pos (To)); + fl_menu_item_set_labeltype (This.Void_Ptr, Label_Kind'Pos (To)); end Set_Label_Type; function Get_Shortcut - (Item : in Menu_Item) + (This : in Menu_Item) return Key_Combo is begin - return To_Ada (Interfaces.C.unsigned_long (fl_menu_item_get_shortcut (Item.Void_Ptr))); + return To_Ada (Interfaces.C.unsigned_long (fl_menu_item_get_shortcut (This.Void_Ptr))); end Get_Shortcut; + procedure Set_Shortcut - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Key_Combo) is begin - fl_menu_item_set_shortcut (Item.Void_Ptr, Interfaces.C.int (To_C (To))); + fl_menu_item_set_shortcut (This.Void_Ptr, Interfaces.C.int (To_C (To))); end Set_Shortcut; function Get_Flags - (Item : in Menu_Item) + (This : in Menu_Item) return Menu_Flag is begin - return Menu_Flag (fl_menu_item_get_flags (Item.Void_Ptr)); + return Menu_Flag (fl_menu_item_get_flags (This.Void_Ptr)); end Get_Flags; procedure Set_Flags - (Item : in out Menu_Item; + (This : in out Menu_Item; To : in Menu_Flag) is begin - fl_menu_item_set_flags (Item.Void_Ptr, Interfaces.C.unsigned_long (To)); + fl_menu_item_set_flags (This.Void_Ptr, Interfaces.C.unsigned_long (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 - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_activate (Item.Void_Ptr); + fl_menu_item_activate (This.Void_Ptr); end Activate; procedure Deactivate - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_deactivate (Item.Void_Ptr); + fl_menu_item_deactivate (This.Void_Ptr); end Deactivate; procedure Show - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_show (Item.Void_Ptr); + fl_menu_item_show (This.Void_Ptr); end Show; procedure Hide - (Item : in out Menu_Item) is + (This : in out Menu_Item) is begin - fl_menu_item_hide (Item.Void_Ptr); + fl_menu_item_hide (This.Void_Ptr); end Hide; function Is_Active - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_active (Item.Void_Ptr) /= 0; + return fl_menu_item_active (This.Void_Ptr) /= 0; end Is_Active; function Is_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_visible (Item.Void_Ptr) /= 0; + return fl_menu_item_visible (This.Void_Ptr) /= 0; end Is_Visible; function Is_Active_And_Visible - (Item : in Menu_Item) + (This : in Menu_Item) return Boolean is begin - return fl_menu_item_activevisible (Item.Void_Ptr) /= 0; + return fl_menu_item_activevisible (This.Void_Ptr) /= 0; end Is_Active_And_Visible; end FLTK.Menu_Items; + |