summaryrefslogtreecommitdiff
path: root/src/fltk-environment.adb
diff options
context:
space:
mode:
Diffstat (limited to 'src/fltk-environment.adb')
-rw-r--r--src/fltk-environment.adb522
1 files changed, 522 insertions, 0 deletions
diff --git a/src/fltk-environment.adb b/src/fltk-environment.adb
new file mode 100644
index 0000000..22a0bd9
--- /dev/null
+++ b/src/fltk-environment.adb
@@ -0,0 +1,522 @@
+
+
+with
+
+ Interfaces.C.Strings,
+ System;
+
+use type
+
+ Interfaces.C.int,
+ System.Address;
+
+
+package body FLTK.Environment is
+
+
+ function new_fl_preferences
+ (P, V, A : in Interfaces.C.char_array)
+ return System.Address;
+ pragma Import (C, new_fl_preferences, "new_fl_preferences");
+
+ procedure free_fl_preferences
+ (E : in System.Address);
+ pragma Import (C, free_fl_preferences, "free_fl_preferences");
+
+
+
+
+ function fl_preferences_entries
+ (E : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_entries, "fl_preferences_entries");
+
+ function fl_preferences_entry
+ (E : in System.Address;
+ I : in Interfaces.C.int)
+ return Interfaces.C.Strings.chars_ptr;
+ pragma Import (C, fl_preferences_entry, "fl_preferences_entry");
+
+ function fl_preferences_entryexists
+ (E : in System.Address;
+ K : in Interfaces.C.char_array)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_entryexists, "fl_preferences_entryexists");
+
+ function fl_preferences_size
+ (E : in System.Address;
+ K : in Interfaces.C.char_array)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_size, "fl_preferences_size");
+
+
+
+
+ function fl_preferences_get_int
+ (E : in System.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");
+
+ function fl_preferences_get_float
+ (E : in System.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");
+
+ function fl_preferences_get_double
+ (E : in System.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");
+
+ function fl_preferences_get_str
+ (E : in System.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");
+
+
+
+
+ function fl_preferences_set_int
+ (E : in System.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");
+
+ function fl_preferences_set_float
+ (E : in System.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");
+
+ function fl_preferences_set_float_prec
+ (E : in System.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");
+
+ function fl_preferences_set_double
+ (E : in System.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");
+
+ function fl_preferences_set_double_prec
+ (E : in System.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");
+
+ function fl_preferences_set_str
+ (E : in System.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");
+
+
+
+
+ function fl_preferences_deleteentry
+ (E : in System.Address;
+ K : in Interfaces.C.char_array)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_deleteentry, "fl_preferences_deleteentry");
+
+ function fl_preferences_deleteallentries
+ (E : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_deleteallentries, "fl_preferences_deleteallentries");
+
+ function fl_preferences_clear
+ (E : in System.Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_preferences_clear, "fl_preferences_clear");
+
+
+
+
+ procedure fl_preferences_flush
+ (E : in System.Address);
+ pragma Import (C, fl_preferences_flush, "fl_preferences_flush");
+
+
+
+
+ procedure Finalize
+ (This : in out Preferences) is
+ begin
+ if This.Void_Ptr /= System.Null_Address and then
+ This in Preferences'Class
+ then
+ free_fl_preferences (This.Void_Ptr);
+ This.Void_Ptr := System.Null_Address;
+ end if;
+ end Finalize;
+
+
+
+
+ package body Forge is
+
+ function From_Filesystem
+ (Path, Vendor, Application : in String)
+ return Preferences is
+ begin
+ return This : Preferences do
+ This.Void_Ptr := new_fl_preferences
+ (Interfaces.C.To_C (Path),
+ Interfaces.C.To_C (Vendor),
+ Interfaces.C.To_C (Application));
+ end return;
+ end From_Filesystem;
+
+ end Forge;
+
+
+
+
+ function Number_Of_Entries
+ (This : in Preferences)
+ 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)
+ return String
+ is
+ Key : Interfaces.C.Strings.chars_ptr :=
+ fl_preferences_entry (This.Void_Ptr, Interfaces.C.int (Index));
+ Str : String := Interfaces.C.Strings.Value (Key);
+ begin
+ return Str;
+ end Get_Key;
+
+
+ function Entry_Exists
+ (This : in Preferences;
+ Key : in String)
+ return Boolean is
+ begin
+ return fl_preferences_entryexists (This.Void_Ptr, Interfaces.C.To_C (Key)) /= 0;
+ end Entry_Exists;
+
+
+ function Entry_Size
+ (This : in Preferences;
+ Key : in String)
+ return Natural is
+ begin
+ return Natural (fl_preferences_size (This.Void_Ptr, Interfaces.C.To_C (Key)));
+ end Entry_Size;
+
+
+
+
+ function Get
+ (This : in Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ Key : in String)
+ return String
+ is
+ Value : Interfaces.C.Strings.chars_ptr;
+ Check : Interfaces.C.int := fl_preferences_get_str
+ (This.Void_Ptr,
+ Interfaces.C.To_C (Key),
+ Value,
+ Interfaces.C.To_C ("default"));
+ Str : String := Interfaces.C.Strings.Value (Value);
+ begin
+ Interfaces.C.Strings.Free (Value);
+ if Check = 0 then
+ raise Preference_Error;
+ end if;
+ return Str;
+ end Get;
+
+
+
+
+ function Get
+ (This : in Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ Key : in String;
+ Default : in String)
+ return String
+ is
+ Value : Interfaces.C.Strings.chars_ptr;
+ X : Interfaces.C.int := fl_preferences_get_str
+ (This.Void_Ptr,
+ Interfaces.C.To_C (Key),
+ Value,
+ Interfaces.C.To_C (Default));
+ Str : String := Interfaces.C.Strings.Value (Value);
+ begin
+ Interfaces.C.Strings.Free (Value);
+ return Str;
+ end Get;
+
+
+
+
+ procedure Set
+ (This : in out Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 Preferences;
+ 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 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
+ begin
+ if fl_preferences_clear (This.Void_Ptr) = 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 FLTK.Environment;
+
generated by cgit (git 2.30.0) at 2024-05-05 23:41:41 +0000