diff options
Diffstat (limited to 'src/fltk-widgets-groups-help_views.adb')
| -rw-r--r-- | src/fltk-widgets-groups-help_views.adb | 572 |
1 files changed, 572 insertions, 0 deletions
diff --git a/src/fltk-widgets-groups-help_views.adb b/src/fltk-widgets-groups-help_views.adb new file mode 100644 index 0000000..b1ac905 --- /dev/null +++ b/src/fltk-widgets-groups-help_views.adb @@ -0,0 +1,572 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C.Strings, + System.Address_To_Access_Conversions; + +use type + + Interfaces.C.int; + + +package body FLTK.Widgets.Groups.Help_Views is + + + ------------------------ + -- Functions From C -- + ------------------------ + + procedure help_view_set_draw_hook + (V, D : in Storage.Integer_Address); + pragma Import (C, help_view_set_draw_hook, "help_view_set_draw_hook"); + pragma Inline (help_view_set_draw_hook); + + procedure help_view_set_handle_hook + (V, H : in Storage.Integer_Address); + pragma Import (C, help_view_set_handle_hook, "help_view_set_handle_hook"); + pragma Inline (help_view_set_handle_hook); + + + + + function new_fl_help_view + (X, Y, W, H : in Interfaces.C.int; + Text : in Interfaces.C.char_array) + return Storage.Integer_Address; + pragma Import (C, new_fl_help_view, "new_fl_help_view"); + pragma Inline (new_fl_help_view); + + procedure free_fl_help_view + (V : in Storage.Integer_Address); + pragma Import (C, free_fl_help_view, "free_fl_help_view"); + pragma Inline (free_fl_help_view); + + + + + procedure fl_help_view_clear_selection + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_clear_selection, "fl_help_view_clear_selection"); + pragma Inline (fl_help_view_clear_selection); + + procedure fl_help_view_select_all + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_select_all, "fl_help_view_select_all"); + pragma Inline (fl_help_view_select_all); + + + + + function fl_help_view_find + (V : in Storage.Integer_Address; + S : in Interfaces.C.char_array; + P : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_help_view_find, "fl_help_view_find"); + pragma Inline (fl_help_view_find); + + function fl_help_view_get_leftline + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_leftline, "fl_help_view_get_leftline"); + pragma Inline (fl_help_view_get_leftline); + + procedure fl_help_view_set_leftline + (V : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_leftline, "fl_help_view_set_leftline"); + pragma Inline (fl_help_view_set_leftline); + + function fl_help_view_get_topline + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_topline, "fl_help_view_get_topline"); + pragma Inline (fl_help_view_get_topline); + + procedure fl_help_view_set_topline + (V : in Storage.Integer_Address; + T : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_topline, "fl_help_view_set_topline"); + pragma Inline (fl_help_view_set_topline); + + procedure fl_help_view_set_topline_target + (V : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_help_view_set_topline_target, "fl_help_view_set_topline_target"); + pragma Inline (fl_help_view_set_topline_target); + + + + + function fl_help_view_directory + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_directory, "fl_help_view_directory"); + pragma Inline (fl_help_view_directory); + + function fl_help_view_filename + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_filename, "fl_help_view_filename"); + pragma Inline (fl_help_view_filename); + + function fl_help_view_load + (V : in Storage.Integer_Address; + F : in Interfaces.C.char_array) + return Interfaces.C.int; + pragma Import (C, fl_help_view_load, "fl_help_view_load"); + pragma Inline (fl_help_view_load); + + function fl_help_view_title + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_title, "fl_help_view_title"); + pragma Inline (fl_help_view_title); + + function fl_help_view_get_value + (V : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_help_view_get_value, "fl_help_view_get_value"); + pragma Inline (fl_help_view_get_value); + + procedure fl_help_view_set_value + (V : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_help_view_set_value, "fl_help_view_set_value"); + pragma Inline (fl_help_view_set_value); + + procedure fl_help_view_link + (V, F : in Storage.Integer_Address); + pragma Import (C, fl_help_view_link, "fl_help_view_link"); + pragma Inline (fl_help_view_link); + + + + + function fl_help_view_get_scrollbar_size + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_scrollbar_size, "fl_help_view_get_scrollbar_size"); + pragma Inline (fl_help_view_get_scrollbar_size); + + procedure fl_help_view_set_scrollbar_size + (V : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_scrollbar_size, "fl_help_view_set_scrollbar_size"); + pragma Inline (fl_help_view_set_scrollbar_size); + + function fl_help_view_get_size + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_size, "fl_help_view_get_size"); + pragma Inline (fl_help_view_get_size); + + procedure fl_help_view_set_size + (V : in Storage.Integer_Address; + W, H : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_size, "fl_help_view_set_size"); + pragma Inline (fl_help_view_set_size); + + function fl_help_view_get_textcolor + (V : in Storage.Integer_Address) + return Interfaces.C.unsigned; + pragma Import (C, fl_help_view_get_textcolor, "fl_help_view_get_textcolor"); + pragma Inline (fl_help_view_get_textcolor); + + procedure fl_help_view_set_textcolor + (V : in Storage.Integer_Address; + C : in Interfaces.C.unsigned); + pragma Import (C, fl_help_view_set_textcolor, "fl_help_view_set_textcolor"); + pragma Inline (fl_help_view_set_textcolor); + + function fl_help_view_get_textfont + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_textfont, "fl_help_view_get_textfont"); + pragma Inline (fl_help_view_get_textfont); + + procedure fl_help_view_set_textfont + (V : in Storage.Integer_Address; + F : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_textfont, "fl_help_view_set_textfont"); + pragma Inline (fl_help_view_set_textfont); + + function fl_help_view_get_textsize + (V : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_help_view_get_textsize, "fl_help_view_get_textsize"); + pragma Inline (fl_help_view_get_textsize); + + procedure fl_help_view_set_textsize + (V : in Storage.Integer_Address; + S : in Interfaces.C.int); + pragma Import (C, fl_help_view_set_textsize, "fl_help_view_set_textsize"); + pragma Inline (fl_help_view_set_textsize); + + + + + procedure fl_help_view_draw + (V : in Storage.Integer_Address); + pragma Import (C, fl_help_view_draw, "fl_help_view_draw"); + pragma Inline (fl_help_view_draw); + + function fl_help_view_handle + (V : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_help_view_handle, "fl_help_view_handle"); + pragma Inline (fl_help_view_handle); + + + + + ---------------------- + -- Callback Hooks -- + ---------------------- + + package Help_View_Convert is new System.Address_To_Access_Conversions (Help_View'Class); + + function Link_Callback_Hook + (V : in Storage.Integer_Address; + S : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.Strings.chars_ptr; + + pragma Convention (C, Link_Callback_Hook); + + function Link_Callback_Hook + (V : in Storage.Integer_Address; + S : in Interfaces.C.Strings.chars_ptr) + return Interfaces.C.Strings.chars_ptr + is + Ada_Help_View : access Help_View'Class := + Help_View_Convert.To_Pointer (Storage.To_Address (fl_widget_get_user_data (V))); + begin + if Ada_Help_View.Zelda = null then + return S; + end if; + Interfaces.C.Strings.Free (Ada_Help_View.Hilda); + Ada_Help_View.Hilda := Interfaces.C.Strings.New_String + (Ada_Help_View.Zelda (Ada_Help_View.all, Interfaces.C.Strings.Value (S))); + if Interfaces.C.Strings.Value (Ada_Help_View.Hilda) = "" then + return Interfaces.C.Strings.Null_Ptr; + else + return Ada_Help_View.Hilda; + end if; + end Link_Callback_Hook; + + + + + ----------------------------------- + -- Controlled Type Subprograms -- + ----------------------------------- + + procedure Finalize + (This : in out Help_View) is + begin + if This.Void_Ptr /= Null_Pointer and then + This in Help_View'Class + then + free_fl_help_view (This.Void_Ptr); + Interfaces.C.Strings.Free (This.Hilda); + This.Void_Ptr := Null_Pointer; + end if; + Finalize (Group (This)); + end Finalize; + + + + + --------------------- + -- Help_View API -- + --------------------- + + package body Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Help_View is + begin + return This : Help_View do + This.Void_Ptr := new_fl_help_view + (Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.To_C (Text)); + fl_widget_set_user_data + (This.Void_Ptr, + Storage.To_Integer (Widget_Convert.To_Address (This'Unchecked_Access))); + help_view_set_draw_hook (This.Void_Ptr, Storage.To_Integer (Draw_Hook'Address)); + help_view_set_handle_hook (This.Void_Ptr, Storage.To_Integer (Handle_Hook'Address)); + fl_help_view_link (This.Void_Ptr, Storage.To_Integer (Link_Callback_Hook'Address)); + fl_widget_set_label (This.Void_Ptr, Interfaces.C.To_C (Text)); + end return; + end Create; + + end Forge; + + + + + procedure Clear_Selection + (This : in out Help_View) is + begin + fl_help_view_clear_selection (This.Void_Ptr); + end Clear_Selection; + + + procedure Select_All + (This : in out Help_View) is + begin + fl_help_view_select_all (This.Void_Ptr); + end Select_All; + + + + + function Find + (This : in Help_View; + Item : in String; + From : in Position := 1) + return Extended_Position is + begin + return Extended_Position (fl_help_view_find + (This.Void_Ptr, + Interfaces.C.To_C (Item), + Interfaces.C.int (From) - 1) + 1); + end Find; + + + function Get_Leftline_Pixel + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_leftline (This.Void_Ptr)); + end Get_Leftline_Pixel; + + + procedure Set_Leftline_Pixel + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_leftline (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Leftline_Pixel; + + + function Get_Topline_Pixel + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_topline (This.Void_Ptr)); + end Get_Topline_Pixel; + + + procedure Set_Topline_Pixel + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_topline (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Topline_Pixel; + + + procedure Set_Topline_Target + (This : in out Help_View; + Value : in String) is + begin + fl_help_view_set_topline_target (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Topline_Target; + + + + + function Current_Directory + (This : in Help_View) + return String is + begin + return Interfaces.C.Strings.Value (fl_help_view_directory (This.Void_Ptr)); + end Current_Directory; + + + function Current_File + (This : in Help_View) + return String is + begin + return Interfaces.C.Strings.Value (fl_help_view_filename (This.Void_Ptr)); + end Current_File; + + + procedure Load + (This : in out Help_View; + Name : in String) + is + Code : Interfaces.C.int := fl_help_view_load (This.Void_Ptr, Interfaces.C.To_C (Name)); + begin + if Code = -1 then + raise Load_Help_Error; + elsif Code /= 0 then + raise Program_Error; + end if; + end Load; + + + function Document_Title + (This : in Help_View) + return String + is + Raw_Chars : Interfaces.C.Strings.chars_ptr := fl_help_view_title (This.Void_Ptr); + use type Interfaces.C.Strings.chars_ptr; + begin + if Raw_Chars = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Raw_Chars); + end if; + end Document_Title; + + + function Get_Content + (This : in Help_View) + return String + is + Raw_Chars : Interfaces.C.Strings.chars_ptr := fl_help_view_get_value (This.Void_Ptr); + use type Interfaces.C.Strings.chars_ptr; + begin + if Raw_Chars = Interfaces.C.Strings.Null_Ptr then + return ""; + else + return Interfaces.C.Strings.Value (Raw_Chars); + end if; + end Get_Content; + + + procedure Set_Content + (This : in out Help_View; + Value : in String) is + begin + fl_help_view_set_value (This.Void_Ptr, Interfaces.C.To_C (Value)); + end Set_Content; + + + procedure Set_Link_Callback + (This : in out Help_View; + Func : in Link_Callback) is + begin + This.Zelda := Func; + end Set_Link_Callback; + + + + + function Get_Scrollbar_Size + (This : in Help_View) + return Natural is + begin + return Natural (fl_help_view_get_scrollbar_size (This.Void_Ptr)); + end Get_Scrollbar_Size; + + + procedure Set_Scrollbar_Size + (This : in out Help_View; + Value : in Natural) is + begin + fl_help_view_set_scrollbar_size (This.Void_Ptr, Interfaces.C.int (Value)); + end Set_Scrollbar_Size; + + + function Get_Size + (This : in Help_View) + return Integer is + begin + return Integer (fl_help_view_get_size (This.Void_Ptr)); + end Get_Size; + + + procedure Resize + (This : in out Help_View; + W, H : in Integer) is + begin + fl_help_view_set_size + (This.Void_Ptr, + Interfaces.C.int (W), + Interfaces.C.int (H)); + end Resize; + + + function Get_Text_Color + (This : in Help_View) + return Color is + begin + return Color (fl_help_view_get_textcolor (This.Void_Ptr)); + end Get_Text_Color; + + + procedure Set_Text_Color + (This : in out Help_View; + Value : in Color) is + begin + fl_help_view_set_textcolor (This.Void_Ptr, Interfaces.C.unsigned (Value)); + end Set_Text_Color; + + + function Get_Text_Font + (This : in Help_View) + return Font_Kind is + begin + return Font_Kind'Val (fl_help_view_get_textfont (This.Void_Ptr)); + end Get_Text_Font; + + + procedure Set_Text_Font + (This : in out Help_View; + Font : in Font_Kind) is + begin + fl_help_view_set_textfont (This.Void_Ptr, Font_Kind'Pos (Font)); + end Set_Text_Font; + + + function Get_Text_Size + (This : in Help_View) + return Font_Size is + begin + return Font_Size (fl_help_view_get_textsize (This.Void_Ptr)); + end Get_Text_Size; + + + procedure Set_Text_Size + (This : in out Help_View; + Size : in Font_Size) is + begin + fl_help_view_set_textsize (This.Void_Ptr, Interfaces.C.int (Size)); + end Set_Text_Size; + + + + + procedure Draw + (This : in out Help_View) is + begin + fl_help_view_draw (This.Void_Ptr); + end Draw; + + + function Handle + (This : in out Help_View; + Event : in Event_Kind) + return Event_Outcome is + begin + return Event_Outcome'Val + (fl_help_view_handle (This.Void_Ptr, Event_Kind'Pos (Event))); + end Handle; + + +end FLTK.Widgets.Groups.Help_Views; + + |