diff options
Diffstat (limited to 'body/fltk-asks.adb')
| -rw-r--r-- | body/fltk-asks.adb | 130 |
1 files changed, 100 insertions, 30 deletions
diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb index bd09fac..8d4f900 100644 --- a/body/fltk-asks.adb +++ b/body/fltk-asks.adb @@ -27,6 +27,8 @@ package body FLTK.Asks is -- Functions From C -- ------------------------ + -- Static Attributes -- + function fl_ask_get_cancel return Interfaces.C.Strings.chars_ptr; pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel"); @@ -80,6 +82,8 @@ package body FLTK.Asks is + -- Simple Messages -- + procedure fl_ask_alert (M : in Interfaces.C.char_array); pragma Import (C, fl_ask_alert, "fl_ask_alert"); @@ -124,6 +128,8 @@ package body FLTK.Asks is + -- Choosers -- + function fl_ask_color_chooser (N : in Interfaces.C.char_array; R, G, B : in out Interfaces.C.double; @@ -140,6 +146,12 @@ package body FLTK.Asks is pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); pragma Inline (fl_ask_color_chooser2); + function fl_ask_show_colormap + (H : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_ask_show_colormap, "fl_ask_show_colormap"); + pragma Inline (fl_ask_show_colormap); + function fl_ask_dir_chooser (M, D : in Interfaces.C.char_array; R : in Interfaces.C.int) @@ -167,6 +179,8 @@ package body FLTK.Asks is + -- Settings -- + function fl_ask_get_message_hotspot return Interfaces.C.int; pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot"); @@ -220,9 +234,9 @@ package body FLTK.Asks is - --------------- - -- Cleanup -- - --------------- + ------------------- + -- Destructors -- + ------------------- procedure Finalize (This : in out Dialog_String_Final_Controller) @@ -240,9 +254,26 @@ package body FLTK.Asks is - ------------------ - -- Attributes -- - ------------------ + -------------------- + -- Constructors -- + -------------------- + + -- You can get out of a hole by digging deeper, right? + procedure fl_box_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_box_extra_init, "fl_box_extra_init"); + pragma Inline (fl_box_extra_init); + + + + + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Static Attributes -- function Get_Cancel_String return String is @@ -326,9 +357,7 @@ package body FLTK.Asks is - ---------------------- - -- Common Dialogs -- - ---------------------- + -- Simple Messages -- procedure Alert (Message : String) is @@ -348,13 +377,17 @@ package body FLTK.Asks is (Message, Button1 : in String) return Choice_Result is - Result : Interfaces.C.int := fl_ask_choice + Result : constant 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); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -363,13 +396,17 @@ package body FLTK.Asks is return Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice + Result : constant 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); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -379,13 +416,17 @@ package body FLTK.Asks is 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 + Result : constant 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); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_choice returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Choice; @@ -393,7 +434,7 @@ package body FLTK.Asks is (Message, Button1 : in String) return Extended_Choice_Result is - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant Interfaces.C.int := fl_ask_choice_n (Interfaces.C.To_C (Message), Interfaces.C.To_C (Button1), Interfaces.C.Strings.Null_Ptr, @@ -402,7 +443,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -411,7 +454,7 @@ package body FLTK.Asks is return Extended_Choice_Result is Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2); - Result : Interfaces.C.int := fl_ask_choice_n + Result : constant 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), @@ -420,7 +463,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -430,7 +475,7 @@ package body FLTK.Asks is 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 + Result : constant 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), @@ -439,7 +484,9 @@ package body FLTK.Asks is pragma Assert (Result in -3 .. 2); return Extended_Choice_Result'Val (Result mod 6); exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_choice_n returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Extended_Choice; @@ -448,7 +495,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_input + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_input (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -473,7 +520,7 @@ package body FLTK.Asks is Default : in String := "") return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_password + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_password (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default)); begin @@ -488,6 +535,8 @@ package body FLTK.Asks is + -- Choosers -- + function Color_Chooser (Title : in String; R, G, B : in out RGB_Float; @@ -498,8 +547,8 @@ package body FLTK.Asks 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 + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -512,7 +561,9 @@ package body FLTK.Asks is return Cancel; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Color_Chooser; @@ -526,8 +577,8 @@ package body FLTK.Asks 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 + M : constant Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode); + Result : constant Interfaces.C.int := fl_ask_color_chooser2 (Interfaces.C.To_C (Title), C_R, C_G, C_B, M); begin if Result = 1 then @@ -540,16 +591,26 @@ package body FLTK.Asks is return Cancel; end if; exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; + when Chk.Assertion_Error => raise Internal_FLTK_Error with + "fl_color_chooser returned unexpected int value of " & + Interfaces.C.int'Image (Result); end Color_Chooser; + function Show_Colormap + (Old_Hue : in Color) + return Color is + begin + return Color (fl_ask_show_colormap (Interfaces.C.unsigned (Old_Hue))); + end Show_Colormap; + + function Dir_Chooser (Message, Default : in String; Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser + Result : constant Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser (Interfaces.C.To_C (Message), Interfaces.C.To_C (Default), Boolean'Pos (Relative)); @@ -568,7 +629,7 @@ package body FLTK.Asks is Relative : in Boolean := False) return String is - Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser + Result : constant 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), @@ -601,6 +662,8 @@ package body FLTK.Asks is + -- Settings -- + function Get_Message_Hotspot return Boolean is begin @@ -644,16 +707,23 @@ package body FLTK.Asks is end Set_Message_Title_Default; - - begin Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon; Wrapper (Icon_Box).Needs_Dealloc := False; + fl_box_extra_init + (Storage.To_Integer (Icon_Box'Address), + Interfaces.C.int (Icon_Box.Get_X), + Interfaces.C.int (Icon_Box.Get_Y), + Interfaces.C.int (Icon_Box.Get_W), + Interfaces.C.int (Icon_Box.Get_H), + Interfaces.C.To_C (Icon_Box.Get_Label)); + fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address)); end FLTK.Asks; + |