-- Programmed by Jedidiah Barber -- Released into the public domain with Interfaces.C.Strings; use type Interfaces.C.int, Interfaces.C.Strings.chars_ptr; package body FLTK.Asks is ------------------------ -- 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 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 Internal_FLTK_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 Internal_FLTK_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 Internal_FLTK_Error; end case; 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; elsif Result = 0 then return Cancel; else raise Internal_FLTK_Error; end if; 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; elsif Result = 0 then return Cancel; else raise Internal_FLTK_Error; end if; 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;