diff options
Diffstat (limited to 'body/fltk-file_choosers.adb')
| -rw-r--r-- | body/fltk-file_choosers.adb | 100 |
1 files changed, 59 insertions, 41 deletions
diff --git a/body/fltk-file_choosers.adb b/body/fltk-file_choosers.adb index 5662f8a..ef33753 100644 --- a/body/fltk-file_choosers.adb +++ b/body/fltk-file_choosers.adb @@ -31,22 +31,24 @@ package body FLTK.File_Choosers is -- Functions From C -- ------------------------ + -- User Data -- + function fl_widget_get_user_data (W : in Storage.Integer_Address) return Storage.Integer_Address; pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); pragma Inline (fl_widget_get_user_data); - procedure fl_widget_set_user_data - (W, D : in Storage.Integer_Address); - pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); - pragma Inline (fl_widget_set_user_data); + -- procedure fl_widget_set_user_data + -- (W, D : in Storage.Integer_Address); + -- pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); + -- pragma Inline (fl_widget_set_user_data); - function fl_file_chooser_get_user_data - (F : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_get_user_data, "fl_file_chooser_get_user_data"); - pragma Inline (fl_file_chooser_get_user_data); + -- function fl_file_chooser_get_user_data + -- (F : in Storage.Integer_Address) + -- return Storage.Integer_Address; + -- pragma Import (C, fl_file_chooser_get_user_data, "fl_file_chooser_get_user_data"); + -- pragma Inline (fl_file_chooser_get_user_data); procedure fl_file_chooser_set_user_data (F, U : in Storage.Integer_Address); @@ -56,6 +58,8 @@ package body FLTK.File_Choosers is + -- Sorting -- + procedure file_chooser_setup_sort_hook; pragma Import (C, file_chooser_setup_sort_hook, "file_chooser_setup_sort_hook"); pragma Inline (file_chooser_setup_sort_hook); @@ -63,6 +67,8 @@ package body FLTK.File_Choosers is + -- Allocation -- + function new_fl_file_chooser (N, P : in Interfaces.C.char_array; K : in Interfaces.C.int; @@ -79,6 +85,8 @@ package body FLTK.File_Choosers is + -- Buttons -- + function fl_file_chooser_newbutton (F : in Storage.Integer_Address) return Storage.Integer_Address; @@ -100,6 +108,8 @@ package body FLTK.File_Choosers is + -- Static Labels -- + function fl_file_chooser_get_add_favorites_label return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_file_chooser_get_add_favorites_label, @@ -257,6 +267,8 @@ package body FLTK.File_Choosers is + -- Callback and Extra -- + function fl_file_chooser_add_extra (F, W : in Storage.Integer_Address) return Storage.Integer_Address; @@ -271,6 +283,8 @@ package body FLTK.File_Choosers is + -- Settings -- + function fl_file_chooser_get_color (F : in Storage.Integer_Address) return Interfaces.C.unsigned; @@ -382,6 +396,8 @@ package body FLTK.File_Choosers is + -- File Selection -- + function fl_file_chooser_count (F : in Storage.Integer_Address) return Interfaces.C.int; @@ -450,6 +466,8 @@ package body FLTK.File_Choosers is + -- Visibility -- + procedure fl_file_chooser_show (F : in Storage.Integer_Address); pragma Import (C, fl_file_chooser_show, "fl_file_chooser_show"); @@ -496,14 +514,13 @@ package body FLTK.File_Choosers is procedure File_Chooser_Callback_Hook - (C_Addr, User_Data : in Storage.Integer_Address); - + (Ignore, User_Data : in Storage.Integer_Address); pragma Convention (C, File_Chooser_Callback_Hook); procedure File_Chooser_Callback_Hook - (C_Addr, User_Data : in Storage.Integer_Address) + (Ignore, User_Data : in Storage.Integer_Address) is - Ada_Obj : access File_Chooser'Class := + Ada_Obj : constant access File_Chooser'Class := File_Chooser_Convert.To_Pointer (Storage.To_Address (User_Data)); begin if Ada_Obj.My_Callback /= null then @@ -518,28 +535,11 @@ package body FLTK.File_Choosers is -- Destructors -- ------------------- - -- Releasing carrier pigeon - procedure fl_button_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_button_extra_final, "fl_button_extra_final"); - pragma Inline (fl_button_extra_final); - - - -- Entering wormhole - procedure fl_check_button_extra_final - (Ada_Obj : in Storage.Integer_Address); - pragma Import (C, fl_check_button_extra_final, "fl_check_button_extra_final"); - pragma Inline (fl_check_button_extra_final); - - procedure Extra_Final (This : in out File_Chooser) is use Interfaces.C.Strings; begin - fl_button_extra_final (Storage.To_Integer (This.New_Butt'Address)); - fl_check_button_extra_final (Storage.To_Integer (This.Preview_Butt'Address)); - fl_check_button_extra_final (Storage.To_Integer (This.Hidden_Butt'Address)); Free (This.My_Label); Free (This.My_OK_Label); end Extra_Final; @@ -673,6 +673,8 @@ package body FLTK.File_Choosers is -- Attributes -- ------------------ + -- Buttons -- + function New_Button (This : in out File_Chooser) return FLTK.Widgets.Buttons.Button_Reference is @@ -703,6 +705,8 @@ package body FLTK.File_Choosers is -- Static Attributes -- ------------------------- + -- Static Labels -- + function Get_Add_Favorites_Label return String is begin @@ -932,22 +936,25 @@ package body FLTK.File_Choosers is -- API Subprograms -- ----------------------- + -- Callback and Extra -- + procedure Add_Extra (This : in out File_Chooser; Item : in out Widgets.Widget'Class) is - C_Addr : Storage.Integer_Address; + Ignore : Storage.Integer_Address := + fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); + null; end Add_Extra; procedure Remove_Extra (This : in out File_Chooser) is - C_Addr : Storage.Integer_Address; + Ignore : Storage.Integer_Address := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); + null; end Remove_Extra; @@ -967,7 +974,8 @@ package body FLTK.File_Choosers is end if; return Ada_Obj; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::add_extra returned Widget with no user_data reference back to Ada"; end Eject_Extra; @@ -981,6 +989,8 @@ package body FLTK.File_Choosers is + -- Settings -- + function Get_Background_Color (This : in File_Chooser) return Color is @@ -1053,12 +1063,14 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return Boolean is - Ret : Interfaces.C.int := fl_file_chooser_get_preview (This.Void_Ptr); + Ret : constant Interfaces.C.int := fl_file_chooser_get_preview (This.Void_Ptr); begin pragma Assert (Ret in 0 .. 1); return Boolean'Val (Ret); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "Fl_File_Chooser::preview returned unexpected int value of " & + Interfaces.C.int'Image (Ret); end Has_Preview; @@ -1122,7 +1134,7 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return Chooser_Kind is - Ret : Interfaces.C.int := fl_file_chooser_get_type (This.Void_Ptr); + Ret : constant Interfaces.C.int := fl_file_chooser_get_type (This.Void_Ptr); begin pragma Assert (Ret in 0 .. Chooser_Kind'Pos (Chooser_Kind'Last)); return Chooser_Kind'Val (Ret); @@ -1143,6 +1155,8 @@ package body FLTK.File_Choosers is + -- File Selection -- + function Number_Selected (This : in File_Chooser) return Natural is @@ -1155,7 +1169,8 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_directory (This.Void_Ptr); + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_directory (This.Void_Ptr); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1186,7 +1201,8 @@ package body FLTK.File_Choosers is (This : in File_Chooser) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_filter (This.Void_Ptr); + C_Ptr : constant Interfaces.C.Strings.chars_ptr := + fl_file_chooser_get_filter (This.Void_Ptr); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then return ""; @@ -1248,7 +1264,7 @@ package body FLTK.File_Choosers is Index : in Positive := 1) return String is - C_Ptr : Interfaces.C.Strings.chars_ptr := + C_Ptr : constant Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_value (This.Void_Ptr, Interfaces.C.int (Index)); begin if C_Ptr = Interfaces.C.Strings.Null_Ptr then @@ -1269,6 +1285,8 @@ package body FLTK.File_Choosers is + -- Visibility -- + procedure Show (This : in out File_Chooser) is begin |