diff options
Diffstat (limited to 'src/fltk-environment.adb')
| -rw-r--r-- | src/fltk-environment.adb | 1089 |
1 files changed, 0 insertions, 1089 deletions
diff --git a/src/fltk-environment.adb b/src/fltk-environment.adb deleted file mode 100644 index 22cf676..0000000 --- a/src/fltk-environment.adb +++ /dev/null @@ -1,1089 +0,0 @@ - - --- 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.Environment is - - - package Chk renames Ada.Assertions; - - - - - ------------------------ - -- Constants From C -- - ------------------------ - - root_fl_prefs_system : constant Interfaces.C.int; - pragma Import (C, root_fl_prefs_system, "root_fl_prefs_system"); - - root_fl_prefs_user : constant Interfaces.C.int; - pragma Import (C, root_fl_prefs_user, "root_fl_prefs_user"); - - const_fl_path_max : constant Interfaces.C.int; - pragma Import (C, const_fl_path_max, "const_fl_path_max"); - - - - - ------------------------ - -- Functions From C -- - ------------------------ - - function fl_preferences_new_uuid - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_preferences_new_uuid, "fl_preferences_new_uuid"); - pragma Inline (fl_preferences_new_uuid); - - - - - function new_fl_pref_database_path - (P, V, A : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_database_path, "new_fl_pref_database_path"); - pragma Inline (new_fl_pref_database_path); - - function new_fl_pref_database_scope - (S : in Interfaces.C.int; - V, A : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_database_scope, "new_fl_pref_database_scope"); - pragma Inline (new_fl_pref_database_scope); - - procedure upref_fl_pref_database - (P : in Storage.Integer_Address); - pragma Import (C, upref_fl_pref_database, "upref_fl_pref_database"); - pragma Inline (upref_fl_pref_database); - - procedure free_fl_pref_database - (E : in Storage.Integer_Address); - pragma Import (C, free_fl_pref_database, "free_fl_pref_database"); - pragma Inline (free_fl_pref_database); - - - - - function new_fl_pref_group_copy - (D : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_group_copy, "new_fl_pref_group_copy"); - pragma Inline (new_fl_pref_group_copy); - - function new_fl_pref_group_memory - (N : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_group_memory, "new_fl_pref_group_memory"); - pragma Inline (new_fl_pref_group_memory); - - function new_fl_pref_group_name - (G : in Storage.Integer_Address; - N : in Interfaces.C.char_array) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_group_name, "new_fl_pref_group_name"); - pragma Inline (new_fl_pref_group_name); - - function new_fl_pref_group_index - (G : in Storage.Integer_Address; - N : in Interfaces.C.int) - return Storage.Integer_Address; - pragma Import (C, new_fl_pref_group_index, "new_fl_pref_group_index"); - pragma Inline (new_fl_pref_group_index); - - procedure free_fl_pref_group - (G : in Storage.Integer_Address); - pragma Import (C, free_fl_pref_group, "free_fl_pref_group"); - pragma Inline (free_fl_pref_group); - - - - - procedure fl_preferences_flush - (E : in Storage.Integer_Address); - pragma Import (C, fl_preferences_flush, "fl_preferences_flush"); - pragma Inline (fl_preferences_flush); - - function fl_preferences_getuserdatapath - (E : in Storage.Integer_Address; - P : in Interfaces.C.char_array; - L : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_getuserdatapath, "fl_preferences_getuserdatapath"); - pragma Inline (fl_preferences_getuserdatapath); - - - - - function fl_preferences_deleteentry - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_deleteentry, "fl_preferences_deleteentry"); - pragma Inline (fl_preferences_deleteentry); - - function fl_preferences_deleteallentries - (E : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_preferences_deleteallentries, "fl_preferences_deleteallentries"); - pragma Inline (fl_preferences_deleteallentries); - - function fl_preferences_deletegroup - (P : in Storage.Integer_Address; - G : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_deletegroup, "fl_preferences_deletegroup"); - pragma Inline (fl_preferences_deletegroup); - - function fl_preferences_deleteallgroups - (P : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_preferences_deleteallgroups, "fl_preferences_deleteallgroups"); - pragma Inline (fl_preferences_deleteallgroups); - - function fl_preferences_clear - (E : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_preferences_clear, "fl_preferences_clear"); - pragma Inline (fl_preferences_clear); - - - - - function fl_preferences_entries - (E : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_preferences_entries, "fl_preferences_entries"); - pragma Inline (fl_preferences_entries); - - function fl_preferences_entry - (E : in Storage.Integer_Address; - I : in Interfaces.C.int) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_preferences_entry, "fl_preferences_entry"); - pragma Inline (fl_preferences_entry); - - function fl_preferences_entryexists - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_entryexists, "fl_preferences_entryexists"); - pragma Inline (fl_preferences_entryexists); - - function fl_preferences_size - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_size, "fl_preferences_size"); - pragma Inline (fl_preferences_size); - - - - - function fl_preferences_groups - (P : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_preferences_groups, "fl_preferences_groups"); - pragma Inline (fl_preferences_groups); - - function fl_preferences_group - (P : in Storage.Integer_Address; - N : in Interfaces.C.int) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_preferences_group, "fl_preferences_group"); - pragma Inline (fl_preferences_group); - - function fl_preferences_groupexists - (P : in Storage.Integer_Address; - G : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_groupexists, "fl_preferences_groupexists"); - pragma Inline (fl_preferences_groupexists); - - - - - function fl_preferences_name - (P : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_preferences_name, "fl_preferences_name"); - pragma Inline (fl_preferences_name); - - function fl_preferences_path - (P : in Storage.Integer_Address) - return Interfaces.C.Strings.chars_ptr; - pragma Import (C, fl_preferences_path, "fl_preferences_path"); - pragma Inline (fl_preferences_path); - - - - - function fl_preferences_get_int - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : out Interfaces.C.int; - D : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_int, "fl_preferences_get_int"); - pragma Inline (fl_preferences_get_int); - - function fl_preferences_get_float - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : out Interfaces.C.C_float; - D : in Interfaces.C.C_float) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_float, "fl_preferences_get_float"); - pragma Inline (fl_preferences_get_float); - - function fl_preferences_get_double - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : out Interfaces.C.double; - D : in Interfaces.C.double) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_double, "fl_preferences_get_double"); - pragma Inline (fl_preferences_get_double); - - function fl_preferences_get_str - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : out Interfaces.C.Strings.chars_ptr; - D : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_str, "fl_preferences_get_str"); - pragma Inline (fl_preferences_get_str); - - function fl_preferences_get_str_limit - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.char_array; - D : in Interfaces.C.char_array; - M : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_str_limit, "fl_preferences_get_str_limit"); - pragma Inline (fl_preferences_get_str_limit); - - function fl_preferences_get_void - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : out Storage.Integer_Address; - D : in Storage.Integer_Address; - DS : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_void, "fl_preferences_get_void"); - pragma Inline (fl_preferences_get_void); - - function fl_preferences_get_void_limit - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V, D : in Storage.Integer_Address; - DS, MS : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_get_void_limit, "fl_preferences_get_void_limit"); - pragma Inline (fl_preferences_get_void_limit); - - procedure free_fl_preferences_void_data - (V : in Storage.Integer_Address); - pragma Import (C, free_fl_preferences_void_data, "free_fl_preferences_void_data"); - pragma Inline (free_fl_preferences_void_data); - - - - - function fl_preferences_set_int - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_int, "fl_preferences_set_int"); - pragma Inline (fl_preferences_set_int); - - function fl_preferences_set_float - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.C_float) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_float, "fl_preferences_set_float"); - pragma Inline (fl_preferences_set_float); - - function fl_preferences_set_float_prec - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.C_float; - P : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_float_prec, "fl_preferences_set_float_prec"); - pragma Inline (fl_preferences_set_float_prec); - - function fl_preferences_set_double - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.double) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_double, "fl_preferences_set_double"); - pragma Inline (fl_preferences_set_double); - - function fl_preferences_set_double_prec - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.double; - P : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_double_prec, "fl_preferences_set_double_prec"); - pragma Inline (fl_preferences_set_double_prec); - - function fl_preferences_set_str - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - V : in Interfaces.C.char_array) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_str, "fl_preferences_set_str"); - pragma Inline (fl_preferences_set_str); - - function fl_preferences_set_void - (E : in Storage.Integer_Address; - K : in Interfaces.C.char_array; - D : in Storage.Integer_Address; - DS : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_preferences_set_void, "fl_preferences_set_void"); - pragma Inline (fl_preferences_set_void); - - - - - ------------------------ - -- Internal Utility -- - ------------------------ - - function To_Cint - (Extent : in Scope) - return Interfaces.C.int is - begin - case Extent is - when Global => - return root_fl_prefs_system; - when User => - return root_fl_prefs_user; - end case; - end To_Cint; - - function To_Scope - (Num : in Interfaces.C.int) - return Scope is - begin - if Num = root_fl_prefs_system then - return Global; - else - pragma Assert (Num = root_fl_prefs_user); - return User; - end if; - exception - when Chk.Assertion_Error => raise Internal_FLTK_Error; - end To_Scope; - - - - - ----------------------------------- - -- Controlled Type Subprograms -- - ----------------------------------- - - procedure Finalize - (This : in out Database) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_pref_database (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - procedure Finalize - (This : in out Pref_Group) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_pref_group (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - if This.Root_Ptr /= Null_Pointer then - free_fl_pref_database (This.Root_Ptr); - end if; - end if; - end Finalize; - - - - - ----------------------- - -- Preferences API -- - ----------------------- - - function New_UUID - return String - is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_new_uuid; - begin - return Interfaces.C.Strings.Value (Text); - end New_UUID; - - - - - package body Forge is - - - function From_Filesystem - (Directory, Vendor, Application : in String) - return Database is - begin - return This : Database do - This.Void_Ptr := new_fl_pref_database_path - (Interfaces.C.To_C (Directory), - Interfaces.C.To_C (Vendor), - Interfaces.C.To_C (Application)); - end return; - end From_Filesystem; - - - function From_Scope - (Extent : in Scope; - Vendor, Application : in String) - return Database is - begin - return This : Database do - This.Void_Ptr := new_fl_pref_database_scope - (To_Cint (Extent), - Interfaces.C.To_C (Vendor), - Interfaces.C.To_C (Application)); - end return; - end From_Scope; - - - function Root - (From : in Database) - return Pref_Group'Class is - begin - return Result : Pref_Group do - Result.Void_Ptr := new_fl_pref_group_copy (From.Void_Ptr); - Result.Root_Ptr := From.Void_Ptr; - upref_fl_pref_database (Result.Root_Ptr); - end return; - end Root; - - - function In_Memory - (Name : in String) - return Pref_Group is - begin - return Result : Pref_Group do - Result.Void_Ptr := new_fl_pref_group_memory (Interfaces.C.To_C (Name)); - Result.Root_Ptr := Null_Pointer; - end return; - end In_Memory; - - - function By_Name - (From : in Pref_Group; - Name : in String) - return Pref_Group'Class is - begin - return Result : Pref_Group do - Result.Void_Ptr := new_fl_pref_group_name - (From.Void_Ptr, - Interfaces.C.To_C (Name)); - Result.Root_Ptr := From.Root_Ptr; - if Result.Root_Ptr /= Null_Pointer then - upref_fl_pref_database (Result.Root_Ptr); - end if; - end return; - end By_Name; - - - function By_Index - (From : in Pref_Group; - Index : in Positive) - return Pref_Group'Class is - begin - return Result : Pref_Group do - Result.Void_Ptr := new_fl_pref_group_index - (From.Void_Ptr, - Interfaces.C.int (Index - 1)); - Result.Root_Ptr := From.Root_Ptr; - if Result.Root_Ptr /= Null_Pointer then - upref_fl_pref_database (Result.Root_Ptr); - end if; - end return; - end By_Index; - - - end Forge; - - - - - procedure Flush - (This : in Database) is - begin - fl_preferences_flush (This.Void_Ptr); - end Flush; - - - function Userdata_Path - (This : in Database) - return String - is - Buffer : Interfaces.C.char_array := - (1 .. Interfaces.C.size_t (const_fl_path_max + 1) => ' '); - begin - if fl_preferences_getuserdatapath - (This.Void_Ptr, - Buffer, - const_fl_path_max) = 0 - then - raise Preference_Error; - end if; - return Interfaces.C.To_Ada (Buffer); - end Userdata_Path; - - - - - procedure Delete_Entry - (This : in out Pref_Group; - Key : in String) is - begin - if fl_preferences_deleteentry (This.Void_Ptr, Interfaces.C.To_C (Key)) = 0 then - raise Preference_Error; - end if; - end Delete_Entry; - - - procedure Delete_All_Entries - (This : in out Pref_Group) is - begin - if fl_preferences_deleteallentries (This.Void_Ptr) = 0 then - raise Preference_Error; - end if; - end Delete_All_Entries; - - - procedure Delete_Group - (This : in out Pref_Group; - Name : in String) is - begin - if fl_preferences_deletegroup (This.Void_Ptr, Interfaces.C.To_C (Name)) = 0 then - raise Preference_Error; - end if; - end Delete_Group; - - - procedure Delete_All_Groups - (This : in out Pref_Group) is - begin - if fl_preferences_deleteallgroups (This.Void_Ptr) = 0 then - raise Preference_Error; - end if; - end Delete_All_Groups; - - - procedure Clear - (This : in out Pref_Group) is - begin - if fl_preferences_clear (This.Void_Ptr) = 0 then - raise Preference_Error; - end if; - end Clear; - - - - - function Number_Of_Entries - (This : in Pref_Group) - return Natural is - begin - return Natural (fl_preferences_entries (This.Void_Ptr)); - end Number_Of_Entries; - - - function Entry_Key - (This : in Pref_Group; - Index : in Positive) - return String - is - Key : Interfaces.C.Strings.chars_ptr := - fl_preferences_entry (This.Void_Ptr, Interfaces.C.int (Index) - 1); - begin - -- no need for dealloc? - if Key = Interfaces.C.Strings.Null_Ptr then - raise Preference_Error; - else - return Interfaces.C.Strings.Value (Key); - end if; - end Entry_Key; - - - function Key_Exists - (This : in Pref_Group; - Key : in String) - return Boolean is - begin - return fl_preferences_entryexists (This.Void_Ptr, Interfaces.C.To_C (Key)) /= 0; - end Key_Exists; - - - function Value_Size - (This : in Pref_Group; - Key : in String) - return Natural is - begin - return Natural (fl_preferences_size (This.Void_Ptr, Interfaces.C.To_C (Key))); - end Value_Size; - - - - - function Number_Of_Groups - (This : in Pref_Group) - return Natural is - begin - return Natural (fl_preferences_groups (This.Void_Ptr)); - end Number_Of_Groups; - - - function Group_Name - (This : in Pref_Group; - Index : in Positive) - return String - is - Name : Interfaces.C.Strings.chars_ptr := - fl_preferences_group (This.Void_Ptr, Interfaces.C.int (Index) - 1); - begin - -- no need for dealloc? - if Name = Interfaces.C.Strings.Null_Ptr then - raise Preference_Error; - else - return Interfaces.C.Strings.Value (Name); - end if; - end Group_Name; - - - function Group_Exists - (This : in Pref_Group; - Name : in String) - return Boolean is - begin - return fl_preferences_groupexists (This.Void_Ptr, Interfaces.C.To_C (Name)) /= 0; - end Group_Exists; - - - - - function At_Name - (This : in Pref_Group) - return String - is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_name (This.Void_Ptr); - begin - if Text = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Text); - end if; - end At_Name; - - - function At_Path - (This : in Pref_Group) - return String - is - Text : Interfaces.C.Strings.chars_ptr := fl_preferences_path (This.Void_Ptr); - begin - if Text = Interfaces.C.Strings.Null_Ptr then - return ""; - else - return Interfaces.C.Strings.Value (Text); - end if; - end At_Path; - - - - - function Get - (This : in Pref_Group; - Key : in String) - return Integer - is - Value : Interfaces.C.int; - begin - if fl_preferences_get_int - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, 0) = 0 - then - raise Preference_Error; - end if; - return Integer (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in Integer) - return Integer - is - Value, X : Interfaces.C.int; - begin - X := fl_preferences_get_int - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, - Interfaces.C.int (Default)); - return Integer (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String) - return Float - is - Value : Interfaces.C.C_float; - begin - if fl_preferences_get_float - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, 0.0) = 0 - then - raise Preference_Error; - end if; - return Float (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in Float) - return Float - is - Value : Interfaces.C.C_float; - X : Interfaces.C.int; - begin - X := fl_preferences_get_float - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, - Interfaces.C.C_float (Default)); - return Float (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String) - return Long_Float - is - Value : Interfaces.C.double; - begin - if fl_preferences_get_double - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, 0.0) = 0 - then - raise Preference_Error; - end if; - return Long_Float (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in Long_Float) - return Long_Float - is - Value : Interfaces.C.double; - X : Interfaces.C.int; - begin - X := fl_preferences_get_double - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Value, - Interfaces.C.double (Default)); - return Long_Float (Value); - end Get; - - - function Get - (This : in Pref_Group; - Key : in String) - return String - is - Text : Interfaces.C.Strings.chars_ptr; - Check : Interfaces.C.int := fl_preferences_get_str - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Text, - Interfaces.C.To_C ("default")); - begin - if Check = 0 then - raise Preference_Error; - end if; - if Text = Interfaces.C.Strings.Null_Ptr then - return ""; - end if; - return Str : String := Interfaces.C.Strings.Value (Text) do - Interfaces.C.Strings.Free (Text); - end return; - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in String) - return String - is - Text : Interfaces.C.Strings.chars_ptr; - X : Interfaces.C.int := fl_preferences_get_str - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Text, - Interfaces.C.To_C (Default)); - begin - if Text = Interfaces.C.Strings.Null_Ptr then - return Default; - end if; - return Str : String := Interfaces.C.Strings.Value (Text) do - Interfaces.C.Strings.Free (Text); - end return; - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in String; - Max_Length : in Natural) - return String - is - Text : Interfaces.C.char_array := (1 .. Interfaces.C.size_t (Max_Length + 1) => ' '); - Check : Interfaces.C.int := fl_preferences_get_str_limit - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Text, - Interfaces.C.To_C (Default), - Interfaces.C.int (Max_Length)); - begin - if Check = 0 then - return Default; - else - return Interfaces.C.To_Ada (Text); - end if; - end Get; - - - function Get - (This : in Pref_Group; - Key : in String) - return Binary_Data - is - Thing : Storage.Integer_Address; - Dummy : Interfaces.C.int := 42; - Check : Interfaces.C.int := fl_preferences_get_void - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Thing, - Storage.To_Integer (Dummy'Address), - 1); - begin - if Check = 0 then - free_fl_preferences_void_data (Thing); - raise Preference_Error; - end if; - declare - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); - Actual : Binary_Data (1 .. Length); - for Actual'Address use Storage.To_Address (Thing); - pragma Import (Ada, Actual); - begin - return Result : Binary_Data := Actual do - free_fl_preferences_void_data (Thing); - end return; - end; - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in Binary_Data) - return Binary_Data - is - Thing : Storage.Integer_Address; - Ignore : Interfaces.C.int := fl_preferences_get_void - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Thing, - Storage.To_Integer (Default'Address), - Default'Length / Interfaces.C.int (c_pointer_size)); - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); - Actual : Binary_Data (1 .. Length); - for Actual'Address use Storage.To_Address (Thing); - pragma Import (Ada, Actual); - begin - return Result : Binary_Data := Actual do - free_fl_preferences_void_data (Thing); - end return; - end Get; - - - function Get - (This : in Pref_Group; - Key : in String; - Default : in Binary_Data; - Max_Length : in Natural) - return Binary_Data - is - Actual : Binary_Data (1 .. Max_Length); - Ignore : Interfaces.C.int := fl_preferences_get_void_limit - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Storage.To_Integer (Actual'Address), - Storage.To_Integer (Default'Address), - Default'Length / Interfaces.C.int (c_pointer_size), - Interfaces.C.int (Max_Length) / Interfaces.C.int (c_pointer_size)); - Length : Natural := This.Value_Size (Key) * Natural (c_pointer_size); - begin - return Actual (1 .. Length); - end Get; - - - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Integer) is - begin - if fl_preferences_set_int - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.int (Value)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Float) is - begin - if fl_preferences_set_float - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.C_float (Value)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Float; - Precision : in Natural) is - begin - if fl_preferences_set_float_prec - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.C_float (Value), - Interfaces.C.int (Precision)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Long_Float) is - begin - if fl_preferences_set_double - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.double (Value)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Long_Float; - Precision : in Natural) is - begin - if fl_preferences_set_double_prec - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.double (Value), - Interfaces.C.int (Precision)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in String) is - begin - if fl_preferences_set_str - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Interfaces.C.To_C (Value)) = 0 - then - raise Preference_Error; - end if; - end Set; - - - procedure Set - (This : in out Pref_Group; - Key : in String; - Value : in Binary_Data) is - begin - if fl_preferences_set_void - (This.Void_Ptr, - Interfaces.C.To_C (Key), - Storage.To_Integer (Value'Address), - Value'Length / Interfaces.C.int (c_pointer_size)) = 0 - then - raise Preference_Error; - end if; - end Set; - - -end FLTK.Environment; - |