diff options
Diffstat (limited to 'src/fltk-asks.adb')
| -rw-r--r-- | src/fltk-asks.adb | 525 |
1 files changed, 417 insertions, 108 deletions
diff --git a/src/fltk-asks.adb b/src/fltk-asks.adb index 880c4c8..2a70358 100644 --- a/src/fltk-asks.adb +++ b/src/fltk-asks.adb @@ -17,148 +17,427 @@ use type package body FLTK.Asks is - procedure dialog_fl_alert - (M : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_alert, "dialog_fl_alert"); - pragma Inline (dialog_fl_alert); + ------------------------ + -- 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); + + - -- function dialog_fl_ask - -- (M : in Interfaces.C.char_array) - -- return Interfaces.C.int; - -- pragma Import (C, dialog_fl_ask, "dialog_fl_ask"); - -- pragma Inline (dialog_fl_ask); - procedure dialog_fl_beep + 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, dialog_fl_beep, "dialog_fl_beep"); - pragma Inline (dialog_fl_beep); + 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 dialog_fl_choice - (M, A, B, C : in Interfaces.C.char_array) + 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, dialog_fl_choice, "dialog_fl_choice"); - pragma Inline (dialog_fl_choice); + pragma Import (C, fl_ask_choice_n, "fl_ask_choice_n"); + pragma Inline (fl_ask_choice_n); - function dialog_fl_input + function fl_ask_input (M, D : in Interfaces.C.char_array) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_input, "dialog_fl_input"); - pragma Inline (dialog_fl_input); + pragma Import (C, fl_ask_input, "fl_ask_input"); + pragma Inline (fl_ask_input); - procedure dialog_fl_message + procedure fl_ask_message (M : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message, "dialog_fl_message"); - pragma Inline (dialog_fl_message); + pragma Import (C, fl_ask_message, "fl_ask_message"); + pragma Inline (fl_ask_message); - function dialog_fl_password + function fl_ask_password (M, D : in Interfaces.C.char_array) return Interfaces.C.Strings.chars_ptr; - pragma Import (C, dialog_fl_password, "dialog_fl_password"); - pragma Inline (dialog_fl_password); + pragma Import (C, fl_ask_password, "fl_ask_password"); + pragma Inline (fl_ask_password); - function dialog_fl_color_chooser + 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, dialog_fl_color_chooser, "dialog_fl_color_chooser"); - pragma Inline (dialog_fl_color_chooser); + pragma Import (C, fl_ask_color_chooser, "fl_ask_color_chooser"); + pragma Inline (fl_ask_color_chooser); - function dialog_fl_color_chooser2 + 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, dialog_fl_color_chooser2, "dialog_fl_color_chooser2"); - pragma Inline (dialog_fl_color_chooser2); + pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); + pragma Inline (fl_ask_color_chooser2); - function dialog_fl_dir_chooser + 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, dialog_fl_dir_chooser, "dialog_fl_dir_chooser"); - pragma Inline (dialog_fl_dir_chooser); + pragma Import (C, fl_ask_dir_chooser, "fl_ask_dir_chooser"); + pragma Inline (fl_ask_dir_chooser); - function dialog_fl_file_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, dialog_fl_file_chooser, "dialog_fl_file_chooser"); - pragma Inline (dialog_fl_file_chooser); + 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 dialog_fl_get_message_hotspot + + function fl_ask_get_message_hotspot return Interfaces.C.int; - pragma Import (C, dialog_fl_get_message_hotspot, "dialog_fl_get_message_hotspot"); - pragma Inline (dialog_fl_get_message_hotspot); + pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); + pragma Inline (fl_ask_get_message_hotspot); - procedure dialog_fl_set_message_hotspot + procedure fl_ask_set_message_hotspot (V : in Interfaces.C.int); - pragma Import (C, dialog_fl_set_message_hotspot, "dialog_fl_set_message_hotspot"); - pragma Inline (dialog_fl_set_message_hotspot); + pragma Import (C, fl_ask_set_message_hotspot, "fl_ask_set_message_hotspot"); + pragma Inline (fl_ask_set_message_hotspot); - procedure dialog_fl_message_font + procedure fl_ask_message_font (F, S : in Interfaces.C.int); - pragma Import (C, dialog_fl_message_font, "dialog_fl_message_font"); - pragma Inline (dialog_fl_message_font); + pragma Import (C, fl_ask_message_font, "fl_ask_message_font"); + pragma Inline (fl_ask_message_font); - function dialog_fl_message_icon + function fl_ask_message_icon return Storage.Integer_Address; - pragma Import (C, dialog_fl_message_icon, "dialog_fl_message_icon"); - pragma Inline (dialog_fl_message_icon); + pragma Import (C, fl_ask_message_icon, "fl_ask_message_icon"); + pragma Inline (fl_ask_message_icon); - procedure dialog_fl_message_title + procedure fl_ask_message_title (T : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message_title, "dialog_fl_message_title"); - pragma Inline (dialog_fl_message_title); + pragma Import (C, fl_ask_message_title, "fl_ask_message_title"); + pragma Inline (fl_ask_message_title); - procedure dialog_fl_message_title_default + procedure fl_ask_message_title_default (T : in Interfaces.C.char_array); - pragma Import (C, dialog_fl_message_title_default, "dialog_fl_message_title_default"); - pragma Inline (dialog_fl_message_title_default); + 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 - dialog_fl_alert (Interfaces.C.To_C (Message)); + fl_ask_alert (Interfaces.C.To_C (Message)); end Alert; - -- function Ask - -- (Message : in String) - -- return Boolean is - -- begin - -- return dialog_fl_ask (Interfaces.C.To_C (Message)) /= 0; - -- end Ask; - - procedure Beep - (Kind : in Beep_Kind) is + (Kind : in Beep_Kind := Default_Beep) is begin - dialog_fl_beep (Beep_Kind'Pos (Kind)); + fl_ask_beep (Beep_Kind'Pos (Kind)); end Beep; - function Three_Way_Choice + 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 + return Choice_Result is - Result : Interfaces.C.int := dialog_fl_choice - (Interfaces.C.To_C (Message), - Interfaces.C.To_C (Button1), - Interfaces.C.To_C (Button2), - Interfaces.C.To_C (Button3)); + 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 - return Choice'Val (Result); - end Three_Way_Choice; + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + 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 + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + 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 + case Result is + when -3 .. -1 => return Extended_Choice_Result'Val (Result + 6); + when 0 .. 2 => return Extended_Choice_Result'Val (Result); + when others => raise Program_Error; + end case; + end Extended_Choice; function Text_Input @@ -166,11 +445,11 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_input + Result : Interfaces.C.Strings.chars_ptr := fl_ask_input (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin - -- string does not need dealloc + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -182,7 +461,7 @@ package body FLTK.Asks is procedure Message_Box (Message : in String) is begin - dialog_fl_message (Interfaces.C.To_C (Message)); + fl_ask_message (Interfaces.C.To_C (Message)); end Message_Box; @@ -191,11 +470,11 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_password + Result : Interfaces.C.Strings.chars_ptr := fl_ask_password (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin - -- string does not need dealloc + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -211,19 +490,25 @@ package body FLTK.Asks is R, G, B : in out RGB_Float; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean + 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 : Boolean := dialog_fl_color_chooser - (Interfaces.C.To_C (Title), C_R, C_G, C_B, M) /= 0; + Result : Interfaces.C.int := fl_ask_color_chooser + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin - R := RGB_Float (C_R); - G := RGB_Float (C_G); - B := RGB_Float (C_B); - return Result; + if Result = 1 then + R := RGB_Float (C_R); + G := RGB_Float (C_G); + B := RGB_Float (C_B); + return Confirm; + elsif Result = 0 then + return Cancel; + else + raise Program_Error; + end if; end Color_Chooser; @@ -232,19 +517,25 @@ package body FLTK.Asks is R, G, B : in out RGB_Int; Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := FLTK.Widgets.Groups.Color_Choosers.RGB) - return Boolean + 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 : Boolean := dialog_fl_color_chooser2 - (Interfaces.C.To_C (Title), C_R, C_G, C_B, M) /= 0; + Result : Interfaces.C.int := fl_ask_color_chooser2 + (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin - R := RGB_Int (C_R); - G := RGB_Int (C_G); - B := RGB_Int (C_B); - return Result; + if Result = 1 then + R := RGB_Int (C_R); + G := RGB_Int (C_G); + B := RGB_Int (C_B); + return Confirm; + elsif Result = 0 then + return Cancel; + else + raise Program_Error; + end if; end Color_Chooser; @@ -253,12 +544,12 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_dir_chooser + Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); begin - -- I'm... fairly sure the string does not need dealloc? + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -272,13 +563,13 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := dialog_fl_file_chooser + 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 - -- I'm... fairly sure the string does not need dealloc? + -- Result does not need dealloc if Result = Interfaces.C.Strings.Null_Ptr then return ""; else @@ -287,27 +578,43 @@ package body FLTK.Asks is end File_Chooser; + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback) is + begin + Chooser_Func := Func; + end Set_File_Chooser_Callback; - function Get_Hotspot + 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 dialog_fl_get_message_hotspot /= 0; - end Get_Hotspot; + return fl_ask_get_message_hotspot /= 0; + end Get_Message_Hotspot; - procedure Set_Hotspot + procedure Set_Message_Hotspot (To : in Boolean) is begin - dialog_fl_set_message_hotspot (Boolean'Pos (To)); - end Set_Hotspot; + 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 - dialog_fl_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); + fl_ask_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size)); end Set_Message_Font; @@ -321,14 +628,14 @@ package body FLTK.Asks is procedure Set_Message_Title (To : in String) is begin - dialog_fl_message_title (Interfaces.C.To_C (To)); + fl_ask_message_title (Interfaces.C.To_C (To)); end Set_Message_Title; procedure Set_Message_Title_Default (To : in String) is begin - dialog_fl_message_title_default (Interfaces.C.To_C (To)); + fl_ask_message_title_default (Interfaces.C.To_C (To)); end Set_Message_Title_Default; @@ -337,9 +644,11 @@ package body FLTK.Asks is begin - Wrapper (Icon_Box).Void_Ptr := dialog_fl_message_icon; + 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; |