From b4438b2fbe895694be98e6e8426103deefc51448 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 21 Jan 2025 21:04:54 +1300 Subject: Split public API and private implementation files into different directories --- body/fltk-asks.adb | 659 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 659 insertions(+) create mode 100644 body/fltk-asks.adb (limited to 'body/fltk-asks.adb') diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb new file mode 100644 index 0000000..bd09fac --- /dev/null +++ b/body/fltk-asks.adb @@ -0,0 +1,659 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Assertions, + Interfaces.C.Strings; + +use type + + Interfaces.C.int, + Interfaces.C.Strings.chars_ptr; + + +package body FLTK.Asks is + + + package Chk renames Ada.Assertions; + + + + + ------------------------ + -- Functions From C -- + ------------------------ + + function fl_ask_get_cancel + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel"); + pragma Inline (fl_ask_get_cancel); + + procedure fl_ask_set_cancel + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_cancel, "fl_ask_set_cancel"); + pragma Inline (fl_ask_set_cancel); + + function fl_ask_get_close + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_close, "fl_ask_get_close"); + pragma Inline (fl_ask_get_close); + + procedure fl_ask_set_close + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_close, "fl_ask_set_close"); + pragma Inline (fl_ask_set_close); + + function fl_ask_get_no + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_no, "fl_ask_get_no"); + pragma Inline (fl_ask_get_no); + + procedure fl_ask_set_no + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_no, "fl_ask_set_no"); + pragma Inline (fl_ask_set_no); + + function fl_ask_get_ok + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_ok, "fl_ask_get_ok"); + pragma Inline (fl_ask_get_ok); + + procedure fl_ask_set_ok + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_ok, "fl_ask_set_ok"); + pragma Inline (fl_ask_set_ok); + + function fl_ask_get_yes + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_get_yes, "fl_ask_get_yes"); + pragma Inline (fl_ask_get_yes); + + procedure fl_ask_set_yes + (V : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_set_yes, "fl_ask_set_yes"); + pragma Inline (fl_ask_set_yes); + + + + + procedure fl_ask_alert + (M : in Interfaces.C.char_array); + pragma Import (C, fl_ask_alert, "fl_ask_alert"); + pragma Inline (fl_ask_alert); + + procedure fl_ask_beep + (B : in Interfaces.C.int); + pragma Import (C, fl_ask_beep, "fl_ask_beep"); + pragma Inline (fl_ask_beep); + + function fl_ask_choice + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Import (C, fl_ask_choice, "fl_ask_choice"); + pragma Inline (fl_ask_choice); + + function fl_ask_choice_n + (M, A : in Interfaces.C.char_array; + B, C : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.int; + pragma Import (C, fl_ask_choice_n, "fl_ask_choice_n"); + pragma Inline (fl_ask_choice_n); + + function fl_ask_input + (M, D : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_input, "fl_ask_input"); + pragma Inline (fl_ask_input); + + procedure fl_ask_message + (M : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message, "fl_ask_message"); + pragma Inline (fl_ask_message); + + function fl_ask_password + (M, D : in Interfaces.C.char_array) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_password, "fl_ask_password"); + pragma Inline (fl_ask_password); + + + + + function fl_ask_color_chooser + (N : in Interfaces.C.char_array; + R, G, B : in out Interfaces.C.double; + M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_ask_color_chooser, "fl_ask_color_chooser"); + pragma Inline (fl_ask_color_chooser); + + function fl_ask_color_chooser2 + (N : in Interfaces.C.char_array; + R, G, B : in out Interfaces.C.unsigned_char; + M : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); + pragma Inline (fl_ask_color_chooser2); + + function fl_ask_dir_chooser + (M, D : in Interfaces.C.char_array; + R : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_dir_chooser, "fl_ask_dir_chooser"); + pragma Inline (fl_ask_dir_chooser); + + function fl_ask_file_chooser + (M, P, D : in Interfaces.C.char_array; + R : in Interfaces.C.int) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_ask_file_chooser, "fl_ask_file_chooser"); + pragma Inline (fl_ask_file_chooser); + + procedure fl_ask_file_chooser_callback + (CB : in Storage.Integer_Address); + pragma Import (C, fl_ask_file_chooser_callback, "fl_ask_file_chooser_callback"); + pragma Inline (fl_ask_file_chooser_callback); + + procedure fl_ask_file_chooser_ok_label + (L : in Interfaces.C.Strings.chars_ptr); + pragma Import (C, fl_ask_file_chooser_ok_label, "fl_ask_file_chooser_ok_label"); + pragma Inline (fl_ask_file_chooser_ok_label); + + + + + function fl_ask_get_message_hotspot + return Interfaces.C.int; + pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); + pragma Inline (fl_ask_get_message_hotspot); + + procedure fl_ask_set_message_hotspot + (V : in Interfaces.C.int); + pragma Import (C, fl_ask_set_message_hotspot, "fl_ask_set_message_hotspot"); + pragma Inline (fl_ask_set_message_hotspot); + + procedure fl_ask_message_font + (F, S : in Interfaces.C.int); + pragma Import (C, fl_ask_message_font, "fl_ask_message_font"); + pragma Inline (fl_ask_message_font); + + function fl_ask_message_icon + return Storage.Integer_Address; + pragma Import (C, fl_ask_message_icon, "fl_ask_message_icon"); + pragma Inline (fl_ask_message_icon); + + procedure fl_ask_message_title + (T : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message_title, "fl_ask_message_title"); + pragma Inline (fl_ask_message_title); + + procedure fl_ask_message_title_default + (T : in Interfaces.C.char_array); + pragma Import (C, fl_ask_message_title_default, "fl_ask_message_title_default"); + pragma Inline (fl_ask_message_title_default); + + + + + --------------------- + -- Callback Hook -- + --------------------- + + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr); + + pragma Convention (C, File_Chooser_Callback_Hook); + + procedure File_Chooser_Callback_Hook + (C_Str : in Interfaces.C.Strings.chars_ptr) is + begin + if Chooser_Func /= null then + Chooser_Func (Interfaces.C.Strings.Value (C_Str)); + end if; + end File_Chooser_Callback_Hook; + + + + + --------------- + -- Cleanup -- + --------------- + + procedure Finalize + (This : in out Dialog_String_Final_Controller) + is + use Interfaces.C.Strings; + begin + Free (Cancel_Str); + Free (Close_Str); + Free (No_Str); + Free (OK_Str); + Free (Yes_Str); + Free (Chooser_OK_Str); + end Finalize; + + + + + ------------------ + -- Attributes -- + ------------------ + + function Get_Cancel_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_cancel); + end Get_Cancel_String; + + + procedure Set_Cancel_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Cancel_Str); + Cancel_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_cancel (Cancel_Str); + end Set_Cancel_String; + + + function Get_Close_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_close); + end Get_Close_String; + + + procedure Set_Close_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Close_Str); + Close_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_close (Close_Str); + end Set_Close_String; + + + function Get_No_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_no); + end Get_No_String; + + + procedure Set_No_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (No_Str); + No_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_no (No_Str); + end Set_No_String; + + + function Get_OK_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_ok); + end Get_OK_String; + + + procedure Set_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (OK_Str); + OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_ok (OK_Str); + end Set_OK_String; + + + function Get_Yes_String + return String is + begin + return Interfaces.C.Strings.Value (fl_ask_get_yes); + end Get_Yes_String; + + + procedure Set_Yes_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Yes_Str); + Yes_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_set_yes (Yes_Str); + end Set_Yes_String; + + + + + ---------------------- + -- Common Dialogs -- + ---------------------- + + procedure Alert + (Message : String) is + begin + fl_ask_alert (Interfaces.C.To_C (Message)); + end Alert; + + + procedure Beep + (Kind : in Beep_Kind := Default_Beep) is + begin + fl_ask_beep (Beep_Kind'Pos (Kind)); + end Beep; + + + function Choice + (Message, Button1 : in String) + return Choice_Result + is + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Choice + (Message, Button1, Button2 : in String) + return Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Choice + (Message, Button1, Button2, Button3 : in String) + return Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : Interfaces.C.int := fl_ask_choice + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + return Choice_Result'Val (Result); + end Choice; + + + function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result + is + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.Null_Ptr, + Interfaces.C.Strings.Null_Ptr); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.Null_Ptr); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Extended_Choice; + + + function Extended_Choice + (Message, Button1, Button2, Button3 : in String) + return Extended_Choice_Result + is + Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); + Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3); + Result : Interfaces.C.int := fl_ask_choice_n + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Button1), + Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access), + Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access)); + begin + pragma Assert (Result in -3 .. 2); + return Extended_Choice_Result'Val (Result mod 6); + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Extended_Choice; + + + function Text_Input + (Message : in String; + Default : in String := "") + return String + is + Result : Interfaces.C.Strings.chars_ptr := fl_ask_input + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Text_Input; + + + procedure Message_Box + (Message : in String) is + begin + fl_ask_message (Interfaces.C.To_C (Message)); + end Message_Box; + + + function Password + (Message : in String; + Default : in String := "") + return String + is + Result : Interfaces.C.Strings.chars_ptr := fl_ask_password + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Password; + + + + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Float; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + FLTK.Widgets.Groups.Color_Choosers.RGB) + return Confirm_Result + is + C_R : Interfaces.C.double := Interfaces.C.double (R); + C_G : Interfaces.C.double := Interfaces.C.double (G); + C_B : Interfaces.C.double := Interfaces.C.double (B); + M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : Interfaces.C.int := fl_ask_color_chooser + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); + begin + if Result = 1 then + R := RGB_Float (C_R); + G := RGB_Float (C_G); + B := RGB_Float (C_B); + return Confirm; + else + pragma Assert (Result = 0); + return Cancel; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Color_Chooser; + + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Int; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + FLTK.Widgets.Groups.Color_Choosers.RGB) + return Confirm_Result + is + C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R); + C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G); + C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B); + M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : Interfaces.C.int := fl_ask_color_chooser2 + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); + begin + if Result = 1 then + R := RGB_Int (C_R); + G := RGB_Int (C_G); + B := RGB_Int (C_B); + return Confirm; + else + pragma Assert (Result = 0); + return Cancel; + end if; + exception + when Chk.Assertion_Error => raise Internal_FLTK_Error; + end Color_Chooser; + + + function Dir_Chooser + (Message, Default : in String; + Relative : in Boolean := False) + return String + is + Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Default), + Boolean'Pos (Relative)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end Dir_Chooser; + + + function File_Chooser + (Message, Filter_Pattern, Default : in String; + Relative : in Boolean := False) + return String + is + Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser + (Interfaces.C.To_C (Message), + Interfaces.C.To_C (Filter_Pattern), + Interfaces.C.To_C (Default), + Boolean'Pos (Relative)); + begin + -- Result does not need dealloc + if Result = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Result); + end if; + end File_Chooser; + + + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback) is + begin + Chooser_Func := Func; + end Set_File_Chooser_Callback; + + + procedure Set_File_Chooser_OK_String + (Value : in String) is + begin + Interfaces.C.Strings.Free (Chooser_OK_Str); + Chooser_OK_Str := Interfaces.C.Strings.New_String (Value); + fl_ask_file_chooser_ok_label (Chooser_OK_Str); + end Set_File_Chooser_OK_String; + + + + + function Get_Message_Hotspot + return Boolean is + begin + return fl_ask_get_message_hotspot /= 0; + end Get_Message_Hotspot; + + + procedure Set_Message_Hotspot + (To : in Boolean) is + begin + fl_ask_set_message_hotspot (Boolean'Pos (To)); + end Set_Message_Hotspot; + + + procedure Set_Message_Font + (Font : in Font_Kind; + Size : in Font_Size) is + begin + fl_ask_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); + end Set_Message_Font; + + + function Get_Message_Icon + return FLTK.Widgets.Boxes.Box_Reference is + begin + return (Data => Icon_Box'Access); + end Get_Message_Icon; + + + procedure Set_Message_Title + (To : in String) is + begin + fl_ask_message_title (Interfaces.C.To_C (To)); + end Set_Message_Title; + + + procedure Set_Message_Title_Default + (To : in String) is + begin + fl_ask_message_title_default (Interfaces.C.To_C (To)); + end Set_Message_Title_Default; + + + + +begin + + + Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; + Wrapper (Icon_Box).Needs_Dealloc := False; + + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); + + +end FLTK.Asks; + -- cgit