diff options
author | Jedidiah Barber <contact@jedbarber.id.au> | 2025-01-21 21:04:54 +1300 |
---|---|---|
committer | Jedidiah Barber <contact@jedbarber.id.au> | 2025-01-21 21:04:54 +1300 |
commit | b4438b2fbe895694be98e6e8426103deefc51448 (patch) | |
tree | 760d86cd7c06420a91dad102cc9546aee73146fc /src/fltk-file_choosers.adb | |
parent | a4703a65b015140cd4a7a985db66264875ade734 (diff) |
Split public API and private implementation files into different directories
Diffstat (limited to 'src/fltk-file_choosers.adb')
-rw-r--r-- | src/fltk-file_choosers.adb | 1308 |
1 files changed, 0 insertions, 1308 deletions
diff --git a/src/fltk-file_choosers.adb b/src/fltk-file_choosers.adb deleted file mode 100644 index 5662f8a..0000000 --- a/src/fltk-file_choosers.adb +++ /dev/null @@ -1,1308 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Ada.Assertions, - Interfaces.C.Strings, - System.Address_To_Access_Conversions; - -use type - - Interfaces.C.int, - Interfaces.C.Strings.chars_ptr; - - -package body FLTK.File_Choosers is - - - package Chk renames Ada.Assertions; - - package File_Chooser_Convert is new System.Address_To_Access_Conversions (File_Chooser'Class); - package Widget_Convert is new System.Address_To_Access_Conversions (Widgets.Widget'Class); - - - - - ------------------------ - -- Functions From C -- - ------------------------ - - 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); - - 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); - pragma Import (C, fl_file_chooser_set_user_data, "fl_file_chooser_set_user_data"); - pragma Inline (fl_file_chooser_set_user_data); - - - - - 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); - - - - - function new_fl_file_chooser - (N, P : in Interfaces.C.char_array; - K : in Interfaces.C.int; - T : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, new_fl_file_chooser, "new_fl_file_chooser"); - pragma Inline (new_fl_file_chooser); - - procedure free_fl_file_chooser - (F : in Storage.Integer_Address); - pragma Import (C, free_fl_file_chooser, "free_fl_file_chooser"); - pragma Inline (free_fl_file_chooser); - - - - - function fl_file_chooser_newbutton - (F : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_newbutton, "fl_file_chooser_newbutton"); - pragma Inline (fl_file_chooser_newbutton); - - function fl_file_chooser_previewbutton - (F : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_previewbutton, "fl_file_chooser_previewbutton"); - pragma Inline (fl_file_chooser_previewbutton); - - function fl_file_chooser_showhiddenbutton - (F : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_showhiddenbutton, "fl_file_chooser_showhiddenbutton"); - pragma Inline (fl_file_chooser_showhiddenbutton); - - - - - function fl_file_chooser_get_add_favorites_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_add_favorites_label, - "fl_file_chooser_get_add_favorites_label"); - pragma Inline (fl_file_chooser_get_add_favorites_label); - - procedure fl_file_chooser_set_add_favorites_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_add_favorites_label, - "fl_file_chooser_set_add_favorites_label"); - pragma Inline (fl_file_chooser_set_add_favorites_label); - - function fl_file_chooser_get_all_files_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_all_files_label, "fl_file_chooser_get_all_files_label"); - pragma Inline (fl_file_chooser_get_all_files_label); - - procedure fl_file_chooser_set_all_files_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_all_files_label, "fl_file_chooser_set_all_files_label"); - pragma Inline (fl_file_chooser_set_all_files_label); - - function fl_file_chooser_get_custom_filter_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_custom_filter_label, - "fl_file_chooser_get_custom_filter_label"); - pragma Inline (fl_file_chooser_get_custom_filter_label); - - procedure fl_file_chooser_set_custom_filter_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_custom_filter_label, - "fl_file_chooser_set_custom_filter_label"); - pragma Inline (fl_file_chooser_set_custom_filter_label); - - function fl_file_chooser_get_existing_file_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_existing_file_label, - "fl_file_chooser_get_existing_file_label"); - pragma Inline (fl_file_chooser_get_existing_file_label); - - procedure fl_file_chooser_set_existing_file_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_existing_file_label, - "fl_file_chooser_set_existing_file_label"); - pragma Inline (fl_file_chooser_set_existing_file_label); - - function fl_file_chooser_get_favorites_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_favorites_label, "fl_file_chooser_get_favorites_label"); - pragma Inline (fl_file_chooser_get_favorites_label); - - procedure fl_file_chooser_set_favorites_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_favorites_label, "fl_file_chooser_set_favorites_label"); - pragma Inline (fl_file_chooser_set_favorites_label); - - function fl_file_chooser_get_filename_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_filename_label, "fl_file_chooser_get_filename_label"); - pragma Inline (fl_file_chooser_get_filename_label); - - procedure fl_file_chooser_set_filename_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_filename_label, "fl_file_chooser_set_filename_label"); - pragma Inline (fl_file_chooser_set_filename_label); - - function fl_file_chooser_get_filesystems_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_filesystems_label, - "fl_file_chooser_get_filesystems_label"); - pragma Inline (fl_file_chooser_get_filesystems_label); - - procedure fl_file_chooser_set_filesystems_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_filesystems_label, - "fl_file_chooser_set_filesystems_label"); - pragma Inline (fl_file_chooser_set_filesystems_label); - - function fl_file_chooser_get_hidden_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_hidden_label, "fl_file_chooser_get_hidden_label"); - pragma Inline (fl_file_chooser_get_hidden_label); - - procedure fl_file_chooser_set_hidden_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_hidden_label, "fl_file_chooser_set_hidden_label"); - pragma Inline (fl_file_chooser_set_hidden_label); - - function fl_file_chooser_get_manage_favorites_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_manage_favorites_label, - "fl_file_chooser_get_manage_favorites_label"); - pragma Inline (fl_file_chooser_get_manage_favorites_label); - - procedure fl_file_chooser_set_manage_favorites_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_manage_favorites_label, - "fl_file_chooser_set_manage_favorites_label"); - pragma Inline (fl_file_chooser_set_manage_favorites_label); - - function fl_file_chooser_get_new_directory_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_new_directory_label, - "fl_file_chooser_get_new_directory_label"); - pragma Inline (fl_file_chooser_get_new_directory_label); - - procedure fl_file_chooser_set_new_directory_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_new_directory_label, - "fl_file_chooser_set_new_directory_label"); - pragma Inline (fl_file_chooser_set_new_directory_label); - - function fl_file_chooser_get_new_directory_tooltip - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_new_directory_tooltip, - "fl_file_chooser_get_new_directory_tooltip"); - pragma Inline (fl_file_chooser_get_new_directory_tooltip); - - procedure fl_file_chooser_set_new_directory_tooltip - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_new_directory_tooltip, - "fl_file_chooser_set_new_directory_tooltip"); - pragma Inline (fl_file_chooser_set_new_directory_tooltip); - - function fl_file_chooser_get_preview_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_preview_label, "fl_file_chooser_get_preview_label"); - pragma Inline (fl_file_chooser_get_preview_label); - - procedure fl_file_chooser_set_preview_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_preview_label, "fl_file_chooser_set_preview_label"); - pragma Inline (fl_file_chooser_set_preview_label); - - function fl_file_chooser_get_save_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_save_label, "fl_file_chooser_get_save_label"); - pragma Inline (fl_file_chooser_get_save_label); - - procedure fl_file_chooser_set_save_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_save_label, "fl_file_chooser_set_save_label"); - pragma Inline (fl_file_chooser_set_save_label); - - function fl_file_chooser_get_show_label - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_show_label, "fl_file_chooser_get_show_label"); - pragma Inline (fl_file_chooser_get_show_label); - - procedure fl_file_chooser_set_show_label - (V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_show_label, "fl_file_chooser_set_show_label"); - pragma Inline (fl_file_chooser_set_show_label); - - - - - function fl_file_chooser_add_extra - (F, W : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_file_chooser_add_extra, "fl_file_chooser_add_extra"); - pragma Inline (fl_file_chooser_add_extra); - - procedure fl_file_chooser_callback - (F, C, U : in Storage.Integer_Address); - pragma Import (C, fl_file_chooser_callback, "fl_file_chooser_callback"); - pragma Inline (fl_file_chooser_callback); - - - - - function fl_file_chooser_get_color - (F : in Storage.Integer_Address) - return Interfaces.C.unsigned; - pragma Import (C, fl_file_chooser_get_color, "fl_file_chooser_get_color"); - pragma Inline (fl_file_chooser_get_color); - - procedure fl_file_chooser_set_color - (F : in Storage.Integer_Address; - V : in Interfaces.C.unsigned); - pragma Import (C, fl_file_chooser_set_color, "fl_file_chooser_set_color"); - pragma Inline (fl_file_chooser_set_color); - - function fl_file_chooser_get_iconsize - (F : in Storage.Integer_Address) - return Interfaces.C.unsigned_char; - pragma Import (C, fl_file_chooser_get_iconsize, "fl_file_chooser_get_iconsize"); - pragma Inline (fl_file_chooser_get_iconsize); - - procedure fl_file_chooser_set_iconsize - (F : in Storage.Integer_Address; - V : in Interfaces.C.unsigned_char); - pragma Import (C, fl_file_chooser_set_iconsize, "fl_file_chooser_set_iconsize"); - pragma Inline (fl_file_chooser_set_iconsize); - - function fl_file_chooser_get_label - (F : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_label, "fl_file_chooser_get_label"); - pragma Inline (fl_file_chooser_get_label); - - procedure fl_file_chooser_set_label - (F : in Storage.Integer_Address; - V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_label, "fl_file_chooser_set_label"); - pragma Inline (fl_file_chooser_set_label); - - function fl_file_chooser_get_ok_label - (F : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_ok_label, "fl_file_chooser_get_ok_label"); - pragma Inline (fl_file_chooser_get_ok_label); - - procedure fl_file_chooser_set_ok_label - (F : in Storage.Integer_Address; - V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_ok_label, "fl_file_chooser_set_ok_label"); - pragma Inline (fl_file_chooser_set_ok_label); - - function fl_file_chooser_get_preview - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_get_preview, "fl_file_chooser_get_preview"); - pragma Inline (fl_file_chooser_get_preview); - - procedure fl_file_chooser_set_preview - (F : in Storage.Integer_Address; - V : in Interfaces.C.int); - pragma Import (C, fl_file_chooser_set_preview, "fl_file_chooser_set_preview"); - pragma Inline (fl_file_chooser_set_preview); - - function fl_file_chooser_get_textcolor - (F : in Storage.Integer_Address) - return Interfaces.C.unsigned; - pragma Import (C, fl_file_chooser_get_textcolor, "fl_file_chooser_get_textcolor"); - pragma Inline (fl_file_chooser_get_textcolor); - - procedure fl_file_chooser_set_textcolor - (F : in Storage.Integer_Address; - V : in Interfaces.C.unsigned); - pragma Import (C, fl_file_chooser_set_textcolor, "fl_file_chooser_set_textcolor"); - pragma Inline (fl_file_chooser_set_textcolor); - - function fl_file_chooser_get_textfont - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_get_textfont, "fl_file_chooser_get_textfont"); - pragma Inline (fl_file_chooser_get_textfont); - - procedure fl_file_chooser_set_textfont - (F : in Storage.Integer_Address; - V : in Interfaces.C.int); - pragma Import (C, fl_file_chooser_set_textfont, "fl_file_chooser_set_textfont"); - pragma Inline (fl_file_chooser_set_textfont); - - function fl_file_chooser_get_textsize - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_get_textsize, "fl_file_chooser_get_textsize"); - pragma Inline (fl_file_chooser_get_textsize); - - procedure fl_file_chooser_set_textsize - (F : in Storage.Integer_Address; - V : in Interfaces.C.int); - pragma Import (C, fl_file_chooser_set_textsize, "fl_file_chooser_set_textsize"); - pragma Inline (fl_file_chooser_set_textsize); - - function fl_file_chooser_get_type - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_get_type, "fl_file_chooser_get_type"); - pragma Inline (fl_file_chooser_get_type); - - procedure fl_file_chooser_set_type - (F : in Storage.Integer_Address; - V : in Interfaces.C.int); - pragma Import (C, fl_file_chooser_set_type, "fl_file_chooser_set_type"); - pragma Inline (fl_file_chooser_set_type); - - - - - function fl_file_chooser_count - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_count, "fl_file_chooser_count"); - pragma Inline (fl_file_chooser_count); - - function fl_file_chooser_get_directory - (F : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_directory, "fl_file_chooser_get_directory"); - pragma Inline (fl_file_chooser_get_directory); - - procedure fl_file_chooser_set_directory - (F : in Storage.Integer_Address; - V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_directory, "fl_file_chooser_set_directory"); - pragma Inline (fl_file_chooser_set_directory); - - function fl_file_chooser_get_filter - (F : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_filter, "fl_file_chooser_get_filter"); - pragma Inline (fl_file_chooser_get_filter); - - procedure fl_file_chooser_set_filter - (F : in Storage.Integer_Address; - V : in Interfaces.C.Strings.chars_ptr); - pragma Import (C, fl_file_chooser_set_filter, "fl_file_chooser_set_filter"); - pragma Inline (fl_file_chooser_set_filter); - - function fl_file_chooser_get_filter_value - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_get_filter_value, "fl_file_chooser_get_filter_value"); - pragma Inline (fl_file_chooser_get_filter_value); - - procedure fl_file_chooser_set_filter_value - (F : in Storage.Integer_Address; - V : in Interfaces.C.int); - pragma Import (C, fl_file_chooser_set_filter_value, "fl_file_chooser_set_filter_value"); - pragma Inline (fl_file_chooser_set_filter_value); - - procedure fl_file_chooser_rescan - (F : in Storage.Integer_Address); - pragma Import (C, fl_file_chooser_rescan, "fl_file_chooser_rescan"); - pragma Inline (fl_file_chooser_rescan); - - procedure fl_file_chooser_rescan_keep_filename - (F : in Storage.Integer_Address); - pragma Import (C, fl_file_chooser_rescan_keep_filename, "fl_file_chooser_rescan_keep_filename"); - pragma Inline (fl_file_chooser_rescan_keep_filename); - - function fl_file_chooser_get_value - (F : in Storage.Integer_Address; - N : in Interfaces.C.int) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_file_chooser_get_value, "fl_file_chooser_get_value"); - pragma Inline (fl_file_chooser_get_value); - - procedure fl_file_chooser_set_value - (F : in Storage.Integer_Address; - V : in Interfaces.C.char_array); - pragma Import (C, fl_file_chooser_set_value, "fl_file_chooser_set_value"); - pragma Inline (fl_file_chooser_set_value); - - - - - procedure fl_file_chooser_show - (F : in Storage.Integer_Address); - pragma Import (C, fl_file_chooser_show, "fl_file_chooser_show"); - pragma Inline (fl_file_chooser_show); - - procedure fl_file_chooser_hide - (F : in Storage.Integer_Address); - pragma Import (C, fl_file_chooser_hide, "fl_file_chooser_hide"); - pragma Inline (fl_file_chooser_hide); - - function fl_file_chooser_shown - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_shown, "fl_file_chooser_shown"); - pragma Inline (fl_file_chooser_shown); - - function fl_file_chooser_visible - (F : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_file_chooser_visible, "fl_file_chooser_visible"); - pragma Inline (fl_file_chooser_visible); - - - - - ---------------------- - -- Callback Hooks -- - ---------------------- - - function File_Chooser_Sort_Hook - (A, B : in Interfaces.C.Strings.chars_ptr) - return Interfaces.C.int; - - pragma Export (C, File_Chooser_Sort_Hook, "file_chooser_sort_hook"); - - function File_Chooser_Sort_Hook - (A, B : in Interfaces.C.Strings.chars_ptr) - return Interfaces.C.int is - begin - return Filenames.Comparison'Pos (Sort_Method - (Interfaces.C.Strings.Value (A), - Interfaces.C.Strings.Value (B))) - 1; - end File_Chooser_Sort_Hook; - - - procedure File_Chooser_Callback_Hook - (C_Addr, 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) - is - Ada_Obj : access File_Chooser'Class := - File_Chooser_Convert.To_Pointer (Storage.To_Address (User_Data)); - begin - if Ada_Obj.My_Callback /= null then - Ada_Obj.My_Callback (Ada_Obj.all); - end if; - end File_Chooser_Callback_Hook; - - - - - ------------------- - -- 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; - - - procedure Finalize - (This : in out File_Chooser) is - begin - Extra_Final (This); - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_file_chooser (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - procedure Finalize - (This : in out File_Chooser_Final_Controller) - is - use Interfaces.C.Strings; - begin - Free (Add_Favorites_Label); - Free (All_Files_Label); - Free (Custom_Filter_Label); - Free (Existing_File_Label); - Free (Favorites_Label); - Free (Filename_Label); - Free (Filesystems_Label); - Free (Hidden_Label); - Free (Manage_Favorites_Label); - Free (New_Directory_Label); - Free (New_Directory_Tooltip); - Free (Preview_Label); - Free (Save_Label); - Free (Show_Label); - end Finalize; - - - - - -------------------- - -- Constructors -- - -------------------- - - -- Bypassing border checkpoints - procedure fl_button_extra_init - (Ada_Obj : in Storage.Integer_Address; - X, Y, W, H : in Interfaces.C.int; - C_Str : in Interfaces.C.char_array); - pragma Import (C, fl_button_extra_init, "fl_button_extra_init"); - pragma Inline (fl_button_extra_init); - - - -- Refracting off language boundaries - procedure fl_check_button_extra_init - (Ada_Obj : in Storage.Integer_Address; - X, Y, W, H : in Interfaces.C.int; - C_Str : in Interfaces.C.char_array); - pragma Import (C, fl_check_button_extra_init, "fl_check_button_extra_init"); - pragma Inline (fl_check_button_extra_init); - - - procedure Extra_Init - (This : in out File_Chooser) is - begin - Wrapper (This.New_Butt).Void_Ptr := fl_file_chooser_newbutton (This.Void_Ptr); - Wrapper (This.New_Butt).Needs_Dealloc := False; - fl_button_extra_init - (Storage.To_Integer (This.New_Butt'Address), - Interfaces.C.int (This.New_Butt.Get_X), - Interfaces.C.int (This.New_Butt.Get_Y), - Interfaces.C.int (This.New_Butt.Get_W), - Interfaces.C.int (This.New_Butt.Get_H), - Interfaces.C.To_C (This.New_Butt.Get_Label)); - - Wrapper (This.Preview_Butt).Void_Ptr := fl_file_chooser_previewbutton (This.Void_Ptr); - Wrapper (This.Preview_Butt).Needs_Dealloc := False; - fl_check_button_extra_init - (Storage.To_Integer (This.Preview_Butt'Address), - Interfaces.C.int (This.Preview_Butt.Get_X), - Interfaces.C.int (This.Preview_Butt.Get_Y), - Interfaces.C.int (This.Preview_Butt.Get_W), - Interfaces.C.int (This.Preview_Butt.Get_H), - Interfaces.C.To_C (This.Preview_Butt.Get_Label)); - - Wrapper (This.Hidden_Butt).Void_Ptr := fl_file_chooser_showhiddenbutton (This.Void_Ptr); - Wrapper (This.Hidden_Butt).Needs_Dealloc := False; - fl_check_button_extra_init - (Storage.To_Integer (This.Hidden_Butt'Address), - Interfaces.C.int (This.Hidden_Butt.Get_X), - Interfaces.C.int (This.Hidden_Butt.Get_Y), - Interfaces.C.int (This.Hidden_Butt.Get_W), - Interfaces.C.int (This.Hidden_Butt.Get_H), - Interfaces.C.To_C (This.Hidden_Butt.Get_Label)); - - fl_file_chooser_set_user_data - (This.Void_Ptr, - Storage.To_Integer (This'Address)); - fl_file_chooser_callback - (This.Void_Ptr, - Storage.To_Integer (File_Chooser_Callback_Hook'Address), - Storage.To_Integer (This'Address)); - end Extra_Init; - - - package body Forge is - - function Create - (Title : in String; - Pattern : in String; - Pathname : in String; - Kind : in Chooser_Kind := Single) - return File_Chooser is - begin - return This : File_Chooser do - This.Void_Ptr := new_fl_file_chooser - (Interfaces.C.To_C (Pathname), - Interfaces.C.To_C (Pattern), - Chooser_Kind'Pos (Kind), - Interfaces.C.To_C (Title)); - Extra_Init (This); - end return; - end Create; - - end Forge; - - - - - ------------------ - -- Attributes -- - ------------------ - - function New_Button - (This : in out File_Chooser) - return FLTK.Widgets.Buttons.Button_Reference is - begin - return (Data => This.New_Butt'Unchecked_Access); - end New_Button; - - - function Preview_Button - (This : in out File_Chooser) - return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference is - begin - return (Data => This.Preview_Butt'Unchecked_Access); - end Preview_Button; - - - function Show_Hidden_Button - (This : in out File_Chooser) - return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference is - begin - return (Data => This.Hidden_Butt'Unchecked_Access); - end Show_Hidden_Button; - - - - - ------------------------- - -- Static Attributes -- - ------------------------- - - function Get_Add_Favorites_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_add_favorites_label); - end Get_Add_Favorites_Label; - - - procedure Set_Add_Favorites_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Add_Favorites_Label); - Add_Favorites_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_add_favorites_label (Add_Favorites_Label); - end Set_Add_Favorites_Label; - - - function Get_All_Files_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_all_files_label); - end Get_All_Files_Label; - - - procedure Set_All_Files_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (All_Files_Label); - All_Files_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_all_files_label (All_Files_Label); - end Set_All_Files_Label; - - - function Get_Custom_Filter_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_custom_filter_label); - end Get_Custom_Filter_Label; - - - procedure Set_Custom_Filter_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Custom_Filter_Label); - Custom_Filter_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_custom_filter_label (Custom_Filter_Label); - end Set_Custom_Filter_Label; - - - function Get_Existing_File_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_existing_file_label); - end Get_Existing_File_Label; - - - procedure Set_Existing_File_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Existing_File_Label); - Existing_File_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_existing_file_label (Existing_File_Label); - end Set_Existing_File_Label; - - - function Get_Favorites_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_favorites_label); - end Get_Favorites_Label; - - - procedure Set_Favorites_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Favorites_Label); - Favorites_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_favorites_label (Favorites_Label); - end Set_Favorites_Label; - - - function Get_Filename_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_filename_label); - end Get_Filename_Label; - - - procedure Set_Filename_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Filename_Label); - Filename_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_filename_label (Filename_Label); - end Set_Filename_Label; - - - function Get_Filesystems_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_filesystems_label); - end Get_Filesystems_Label; - - - procedure Set_Filesystems_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Filesystems_Label); - Filesystems_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_filesystems_label (Filesystems_Label); - end Set_Filesystems_Label; - - - function Get_Hidden_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_hidden_label); - end Get_Hidden_Label; - - - procedure Set_Hidden_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Hidden_Label); - Hidden_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_hidden_label (Hidden_Label); - end Set_Hidden_Label; - - - function Get_Manage_Favorites_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_manage_favorites_label); - end Get_Manage_Favorites_Label; - - - procedure Set_Manage_Favorites_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Manage_Favorites_Label); - Manage_Favorites_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_manage_favorites_label (Manage_Favorites_Label); - end Set_Manage_Favorites_Label; - - - function Get_New_Directory_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_new_directory_label); - end Get_New_Directory_Label; - - - procedure Set_New_Directory_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (New_Directory_Label); - New_Directory_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_new_directory_label (New_Directory_Label); - end Set_New_Directory_Label; - - - function Get_New_Directory_Tooltip - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_new_directory_tooltip); - end Get_New_Directory_Tooltip; - - - procedure Set_New_Directory_Tooltip - (Value : in String) is - begin - Interfaces.C.Strings.Free (New_Directory_Tooltip); - New_Directory_Tooltip := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_new_directory_tooltip (New_Directory_Tooltip); - end Set_New_Directory_Tooltip; - - - function Get_Preview_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_preview_label); - end Get_Preview_Label; - - - procedure Set_Preview_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Preview_Label); - Preview_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_preview_label (Preview_Label); - end Set_Preview_Label; - - - function Get_Save_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_save_label); - end Get_Save_Label; - - - procedure Set_Save_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Save_Label); - Save_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_save_label (Save_Label); - end Set_Save_Label; - - - function Get_Show_Label - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_show_label); - end Get_Show_Label; - - procedure Set_Show_Label - (Value : in String) is - begin - Interfaces.C.Strings.Free (Show_Label); - Show_Label := Interfaces.C.Strings.New_String (Value); - fl_file_chooser_set_show_label (Show_Label); - end Set_Show_Label; - - - - - ----------------------- - -- API Subprograms -- - ----------------------- - - procedure Add_Extra - (This : in out File_Chooser; - Item : in out Widgets.Widget'Class) - is - C_Addr : Storage.Integer_Address; - begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); - end Add_Extra; - - - procedure Remove_Extra - (This : in out File_Chooser) - is - C_Addr : Storage.Integer_Address; - begin - C_Addr := fl_file_chooser_add_extra (This.Void_Ptr, Null_Pointer); - end Remove_Extra; - - - function Eject_Extra - (This : in out File_Chooser; - Item : in out Widgets.Widget'Class) - return access Widgets.Widget'Class - is - C_Addr : Storage.Integer_Address := - fl_file_chooser_add_extra (This.Void_Ptr, Wrapper (Item).Void_Ptr); - Ada_Obj : access Widgets.Widget'Class; - begin - if C_Addr /= Null_Pointer then - C_Addr := fl_widget_get_user_data (C_Addr); - pragma Assert (C_Addr /= Null_Pointer); - Ada_Obj := Widget_Convert.To_Pointer (Storage.To_Address (C_Addr)); - end if; - return Ada_Obj; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end Eject_Extra; - - - procedure Set_Callback - (This : in out File_Chooser; - Func : in Chooser_Callback) is - begin - This.My_Callback := Func; - end Set_Callback; - - - - - function Get_Background_Color - (This : in File_Chooser) - return Color is - begin - return Color (fl_file_chooser_get_color (This.Void_Ptr)); - end Get_Background_Color; - - - procedure Set_Background_Color - (This : in out File_Chooser; - Value : in Color) is - begin - fl_file_chooser_set_color (This.Void_Ptr, Interfaces.C.unsigned (Value)); - end Set_Background_Color; - - - function Get_Icon_Size - (This : in File_Chooser) - return Icon_Size is - begin - return Icon_Size (fl_file_chooser_get_iconsize (This.Void_Ptr)); - end Get_Icon_Size; - - - procedure Set_Icon_Size - (This : in out File_Chooser; - Value : in Icon_Size) is - begin - fl_file_chooser_set_iconsize (This.Void_Ptr, Interfaces.C.unsigned_char (Value)); - end Set_Icon_Size; - - - function Get_Label - (This : in File_Chooser) - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_label (This.Void_Ptr)); - end Get_Label; - - - procedure Set_Label - (This : in out File_Chooser; - Text : in String) is - begin - Interfaces.C.Strings.Free (This.My_Label); - This.My_Label := Interfaces.C.Strings.New_String (Text); - fl_file_chooser_set_label (This.Void_Ptr, This.My_Label); - end Set_Label; - - - function Get_OK_Label - (This : in File_Chooser) - return String is - begin - return Interfaces.C.Strings.Value (fl_file_chooser_get_ok_label (This.Void_Ptr)); - end Get_OK_Label; - - - procedure Set_OK_Label - (This : in out File_Chooser; - Text : in String) is - begin - Interfaces.C.Strings.Free (This.My_OK_Label); - This.My_OK_Label := Interfaces.C.Strings.New_String (Text); - fl_file_chooser_set_ok_label (This.Void_Ptr, This.My_OK_Label); - end Set_OK_Label; - - - function Has_Preview - (This : in File_Chooser) - return Boolean - is - Ret : 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; - end Has_Preview; - - - procedure Set_Preview - (This : in out File_Chooser; - Value : in Boolean) is - begin - fl_file_chooser_set_preview (This.Void_Ptr, Boolean'Pos (Value)); - end Set_Preview; - - - function Get_Text_Color - (This : in File_Chooser) - return Color is - begin - return Color (fl_file_chooser_get_textcolor (This.Void_Ptr)); - end Get_Text_Color; - - - procedure Set_Text_Color - (This : in out File_Chooser; - Value : in Color) is - begin - fl_file_chooser_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); - end Set_Text_Color; - - - function Get_Text_Font - (This : in File_Chooser) - return Font_Kind is - begin - return Font_Kind'Val (fl_file_chooser_get_textfont (This.Void_Ptr)); - end Get_Text_Font; - - - procedure Set_Text_Font - (This : in out File_Chooser; - Font : in Font_Kind) is - begin - fl_file_chooser_set_textfont (This.Void_Ptr, Font_Kind'Pos (Font)); - end Set_Text_Font; - - - function Get_Text_Size - (This : in File_Chooser) - return Font_Size is - begin - return Font_Size (fl_file_chooser_get_textsize (This.Void_Ptr)); - end Get_Text_Size; - - - procedure Set_Text_Size - (This : in out File_Chooser; - Size : in Font_Size) is - begin - fl_file_chooser_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); - end Set_Text_Size; - - - function Get_Kind - (This : in File_Chooser) - return Chooser_Kind - is - Ret : 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); - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error with - "Fl_File_Chooser::type returned unexpected int value of " & - Interfaces.C.int'Image (Ret); - end Get_Kind; - - - procedure Set_Kind - (This : in out File_Chooser; - Kind : in Chooser_Kind) is - begin - fl_file_chooser_set_type (This.Void_Ptr, Chooser_Kind'Pos (Kind)); - end Set_Kind; - - - - - function Number_Selected - (This : in File_Chooser) - return Natural is - begin - return Natural (fl_file_chooser_count (This.Void_Ptr)); - end Number_Selected; - - - function Get_Directory - (This : in File_Chooser) - return String - is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_directory (This.Void_Ptr); - begin - if C_Ptr = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (C_Ptr); - end if; - end Get_Directory; - - - procedure Set_Directory - (This : in out File_Chooser; - Value : in String) - is - use Interfaces.C; - C_Arr : aliased char_array := To_C (Value); - begin - if Value = "" then - fl_file_chooser_set_directory (This.Void_Ptr, Strings.Null_Ptr); - else - fl_file_chooser_set_directory - (This.Void_Ptr, - Strings.To_Chars_Ptr (C_Arr'Unchecked_Access)); - end if; - end Set_Directory; - - - function Get_Filter - (This : in File_Chooser) - return String - is - C_Ptr : Interfaces.C.Strings.chars_ptr := fl_file_chooser_get_filter (This.Void_Ptr); - begin - if C_Ptr = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (C_Ptr); - end if; - end Get_Filter; - - - procedure Set_Filter - (This : in out File_Chooser; - Value : in String) - is - use Interfaces.C; - C_Arr : aliased char_array := To_C (Value); - begin - if Value = "" then - fl_file_chooser_set_filter (This.Void_Ptr, Strings.Null_Ptr); - else - fl_file_chooser_set_filter - (This.Void_Ptr, - Strings.To_Chars_Ptr (C_Arr'Unchecked_Access)); - end if; - end Set_Filter; - - - function Get_Filter_Index - (This : in File_Chooser) - return Positive is - begin - return Positive (fl_file_chooser_get_filter_value (This.Void_Ptr) + 1); - end Get_Filter_Index; - - - procedure Set_Filter_Index - (This : in out File_Chooser; - Value : in Positive) is - begin - fl_file_chooser_set_filter_value (This.Void_Ptr, Interfaces.C.int (Value) - 1); - end Set_Filter_Index; - - - procedure Rescan - (This : in out File_Chooser) is - begin - fl_file_chooser_rescan (This.Void_Ptr); - end Rescan; - - - procedure Rescan_Keep_Filename - (This : in out File_Chooser) is - begin - fl_file_chooser_rescan_keep_filename (This.Void_Ptr); - end Rescan_Keep_Filename; - - - function Get_Selected - (This : in File_Chooser; - Index : in Positive := 1) - return String - is - C_Ptr : 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 - return ""; - else - return Interfaces.C.Strings.Value (C_Ptr); - end if; - end Get_Selected; - - - procedure Set_Selected - (This : in out File_Chooser; - Value : in String) is - begin - fl_file_chooser_set_value (This.Void_Ptr, Interfaces.C.To_C (Value)); - end Set_Selected; - - - - - procedure Show - (This : in out File_Chooser) is - begin - fl_file_chooser_show (This.Void_Ptr); - end Show; - - - procedure Hide - (This : in out File_Chooser) is - begin - fl_file_chooser_hide (This.Void_Ptr); - end Hide; - - - function Is_Shown - (This : in File_Chooser) - return Boolean is - begin - return fl_file_chooser_shown (This.Void_Ptr) /= 0; - end Is_Shown; - - - function Is_Visible - (This : in File_Chooser) - return Boolean is - begin - return fl_file_chooser_visible (This.Void_Ptr) /= 0; - end Is_Visible; - - -begin - - file_chooser_setup_sort_hook; - -end FLTK.File_Choosers; - - |