--  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.Environment is


    ------------------------
    --  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;
        elsif Num = root_fl_prefs_user then
            return User;
        else
            raise Constraint_Error;
        end if;
    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);
        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);
            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;