diff options
Diffstat (limited to 'src/fltk-environment.adb')
| -rw-r--r-- | src/fltk-environment.adb | 828 |
1 files changed, 677 insertions, 151 deletions
diff --git a/src/fltk-environment.adb b/src/fltk-environment.adb index a9bfc88..c13c3ec 100644 --- a/src/fltk-environment.adb +++ b/src/fltk-environment.adb @@ -17,16 +17,141 @@ use type package body FLTK.Environment is - function new_fl_preferences + ------------------------ + -- 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_preferences, "new_fl_preferences"); - pragma Inline (new_fl_preferences); + 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); - procedure free_fl_preferences + 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, free_fl_preferences, "free_fl_preferences"); - pragma Inline (free_fl_preferences); + 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); @@ -61,6 +186,44 @@ package body FLTK.Environment is + 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; @@ -97,6 +260,40 @@ package body FLTK.Environment is 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); + @@ -150,119 +347,382 @@ package body FLTK.Environment is 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); - 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); + ------------------------ + -- Internal Utility -- + ------------------------ - 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 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; + elsif Num = root_fl_prefs_user then + return User; + else + raise Constraint_Error; + end if; + end To_Scope; - procedure fl_preferences_flush - (E : in Storage.Integer_Address); - pragma Import (C, fl_preferences_flush, "fl_preferences_flush"); - pragma Inline (fl_preferences_flush); - + ----------------------------------- + -- Controlled Type Subprograms -- + ----------------------------------- + procedure Finalize + (This : in out Database) is + begin + if This.Void_Ptr /= Null_Pointer and then + This in Database'Class + then + free_fl_pref_database (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + Finalize (Wrapper (This)); + end Finalize; procedure Finalize - (This : in out Preferences) is + (This : in out Pref_Group) is begin if This.Void_Ptr /= Null_Pointer and then - This in Preferences'Class + This in Pref_Group'Class then - free_fl_preferences (This.Void_Ptr); + free_fl_pref_group (This.Void_Ptr); + if This.Root_Ptr /= Null_Pointer then + free_fl_pref_database (This.Root_Ptr); + This.Root_Ptr := Null_Pointer; + end if; This.Void_Ptr := Null_Pointer; end if; + Finalize (Wrapper (This)); 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 - (Path, Vendor, Application : in String) - return Preferences is + (Directory, Vendor, Application : in String) + return Database is begin - return This : Preferences do - This.Void_Ptr := new_fl_preferences - (Interfaces.C.To_C (Path), + 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 Preferences) + (This : in Pref_Group) return Natural is begin return Natural (fl_preferences_entries (This.Void_Ptr)); end Number_Of_Entries; - function Get_Key - (This : in Preferences; - Index : in Natural) + 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)); + 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 Constraint_Error; + raise Preference_Error; else return Interfaces.C.Strings.Value (Key); end if; - end Get_Key; + end Entry_Key; - function Entry_Exists - (This : in Preferences; + 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 Entry_Exists; + end Key_Exists; - function Entry_Size - (This : in Preferences; + 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 Entry_Size; + 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 Preferences; + (This : in Pref_Group; Key : in String) return Integer is @@ -280,7 +740,24 @@ package body FLTK.Environment is function Get - (This : in Preferences; + (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 @@ -298,7 +775,25 @@ package body FLTK.Environment is function Get - (This : in Preferences; + (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 @@ -316,118 +811,172 @@ package body FLTK.Environment is function Get - (This : in Preferences; + (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 - Value : Interfaces.C.Strings.chars_ptr; + Text : Interfaces.C.Strings.chars_ptr; Check : Interfaces.C.int := fl_preferences_get_str (This.Void_Ptr, Interfaces.C.To_C (Key), - Value, + Text, Interfaces.C.To_C ("default")); begin if Check = 0 then raise Preference_Error; end if; - if Value = Interfaces.C.Strings.Null_Ptr then + if Text = Interfaces.C.Strings.Null_Ptr then return ""; - else - declare - Str : String := Interfaces.C.Strings.Value (Value); - begin - Interfaces.C.Strings.Free (Value); - return Str; - end; end if; + return Str : String := Interfaces.C.Strings.Value (Text) do + Interfaces.C.Strings.Free (Text); + end return; end Get; - - function Get - (This : in Preferences; + (This : in Pref_Group; Key : in String; - Default : in Integer) - return Integer + Default : in String) + return String is - Value, X : Interfaces.C.int; - begin - X := fl_preferences_get_int + Text : Interfaces.C.Strings.chars_ptr; + X : Interfaces.C.int := fl_preferences_get_str (This.Void_Ptr, Interfaces.C.To_C (Key), - Value, - Interfaces.C.int (Default)); - return Integer (Value); + 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 Preferences; - Key : in String; - Default : in Float) - return Float + (This : in Pref_Group; + Key : in String; + Default : in String; + Max_Length : in Natural) + return String is - Value : Interfaces.C.C_float; - X : Interfaces.C.int; + 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 - X := fl_preferences_get_float + 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), - Value, - Interfaces.C.C_float (Default)); - return Float (Value); + 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 Preferences; + (This : in Pref_Group; Key : in String; - Default : in Long_Float) - return Long_Float + Default : in Binary_Data) + return Binary_Data is - Value : Interfaces.C.double; - X : Interfaces.C.int; - begin - X := fl_preferences_get_double + Thing : Storage.Integer_Address; + Ignore : Interfaces.C.int := fl_preferences_get_void (This.Void_Ptr, Interfaces.C.To_C (Key), - Value, - Interfaces.C.double (Default)); - return Long_Float (Value); + 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 Preferences; - Key : in String; - Default : in String) - return String + (This : in Pref_Group; + Key : in String; + Default : in Binary_Data; + Max_Length : in Natural) + return Binary_Data is - Value : Interfaces.C.Strings.chars_ptr; - X : Interfaces.C.int := fl_preferences_get_str + Actual : Binary_Data (1 .. Max_Length); + Ignore : Interfaces.C.int := fl_preferences_get_void_limit (This.Void_Ptr, Interfaces.C.To_C (Key), - Value, - Interfaces.C.To_C (Default)); + 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 - if Value = Interfaces.C.Strings.Null_Ptr then - return ""; - else - declare - Str : String := Interfaces.C.Strings.Value (Value); - begin - Interfaces.C.Strings.Free (Value); - return Str; - end; - end if; + return Actual (1 .. Length); end Get; procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in Integer) is begin @@ -442,7 +991,7 @@ package body FLTK.Environment is procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in Float) is begin @@ -457,7 +1006,7 @@ package body FLTK.Environment is procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in Float; Precision : in Natural) is @@ -474,7 +1023,7 @@ package body FLTK.Environment is procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in Long_Float) is begin @@ -489,7 +1038,7 @@ package body FLTK.Environment is procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in Long_Float; Precision : in Natural) is @@ -506,7 +1055,7 @@ package body FLTK.Environment is procedure Set - (This : in out Preferences; + (This : in out Pref_Group; Key : in String; Value : in String) is begin @@ -520,43 +1069,20 @@ package body FLTK.Environment is end Set; - - - procedure Delete_Entry - (This : in out Preferences; - 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 Preferences) is - begin - if fl_preferences_deleteallentries (This.Void_Ptr) = 0 then - raise Preference_Error; - end if; - end Delete_All_Entries; - - - procedure Clear - (This : in out Preferences) is + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Binary_Data) is begin - if fl_preferences_clear (This.Void_Ptr) = 0 then + 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 Clear; - - - - - procedure Flush - (This : in Preferences) is - begin - fl_preferences_flush (This.Void_Ptr); - end Flush; + end Set; end FLTK.Environment; |