From 651f6158b0ac53d5d21eaeebc99b23b64800e2c3 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Wed, 28 Mar 2018 02:16:43 +1100 Subject: Added FLTK.Environment (aka Fl_Preferences) --- progress.txt | 16 +- src/c_fl_preferences.cpp | 105 ++++++++++ src/c_fl_preferences.h | 49 +++++ src/fltk-environment.adb | 522 +++++++++++++++++++++++++++++++++++++++++++++++ src/fltk-environment.ads | 163 +++++++++++++++ 5 files changed, 848 insertions(+), 7 deletions(-) create mode 100644 src/c_fl_preferences.cpp create mode 100644 src/c_fl_preferences.h create mode 100644 src/fltk-environment.adb create mode 100644 src/fltk-environment.ads diff --git a/progress.txt b/progress.txt index 2d47916..e92bd6c 100644 --- a/progress.txt +++ b/progress.txt @@ -96,6 +96,7 @@ FLTK FLTK.Devices.Graphics FLTK.Devices.Surfaces FLTK.Devices.Surfaces.Image +FLTK.Environment FLTK.Menu_Items FLTK.Screen FLTK.Text_Buffers @@ -125,13 +126,20 @@ FL_Help_View FL_Table FL_Table_Row FL_Tree -FL_Preferences FL_Label +FL_Postscript_File_Device +FL_Postscript_Printer +FL_Overlay_Window +FL_GL_Window +FL_Glut_Window +FL_Cairo_Window - mark all methods as inline - make sure all C++ reinterpret_cast for methods is to the Fl object, not the My object, because inheriting - consistent unicode utf-8 support (is this even fully supported by FLTK?) - make all protected methods available +- check FLTK library internals to see which char* return values need dealloc +- remove custom exception types in favour of Program_Error? @@ -154,8 +162,6 @@ FL_Free FL_Sys_Menu_Bar FL_Positioner FL_Timer -FL_Postscript_File_Device -FL_Postscript_Printer FL_System_Printer FL_GDI_Graphics_Driver FL_Postscript_Graphics_Driver @@ -164,10 +170,6 @@ FL_Xlib_Graphics_Driver FL_Plugin FL_Plugin_Manager FL_Device_Plugin -FL_Overlay_Window -FL_GL_Window -FL_Glut_Window -FL_Cairo_Window diff --git a/src/c_fl_preferences.cpp b/src/c_fl_preferences.cpp new file mode 100644 index 0000000..bd36806 --- /dev/null +++ b/src/c_fl_preferences.cpp @@ -0,0 +1,105 @@ + + +#include +#include "c_fl_preferences.h" + + + + +PREFS new_fl_preferences(char * p, char * v, char * a) { + Fl_Preferences *e = new Fl_Preferences(p,v,a); + return e; +} + +void free_fl_preferences(PREFS e) { + delete reinterpret_cast(e); +} + + + + +int fl_preferences_entries(PREFS e) { + return reinterpret_cast(e)->entries(); +} + +const char * fl_preferences_entry(PREFS e, int i) { + return reinterpret_cast(e)->entry(i); +} + +int fl_preferences_entryexists(PREFS e, const char * k) { + return reinterpret_cast(e)->entryExists(k); +} + +int fl_preferences_size(PREFS e, const char * k) { + return reinterpret_cast(e)->size(k); +} + + + + +int fl_preferences_get_int(PREFS e, const char * k, int& v, int d) { + return reinterpret_cast(e)->get(k,v,d); +} + +int fl_preferences_get_float(PREFS e, const char * k, float& v, float d) { + return reinterpret_cast(e)->get(k,v,d); +} + +int fl_preferences_get_double(PREFS e, const char * k, double& v, double d) { + return reinterpret_cast(e)->get(k,v,d); +} + +int fl_preferences_get_str(PREFS e, const char * k, char *& v, const char * d) { + return reinterpret_cast(e)->get(k,v,d); +} + + + + +int fl_preferences_set_int(PREFS e, const char * k, int v) { + return reinterpret_cast(e)->set(k,v); +} + +int fl_preferences_set_float(PREFS e, const char * k, float v) { + return reinterpret_cast(e)->set(k,v); +} + +int fl_preferences_set_float_prec(PREFS e, const char * k, float v, int p) { + return reinterpret_cast(e)->set(k,v,p); +} + +int fl_preferences_set_double(PREFS e, const char * k, double v) { + return reinterpret_cast(e)->set(k,v); +} + +int fl_preferences_set_double_prec(PREFS e, const char * k, double v, int p) { + return reinterpret_cast(e)->set(k,v,p); +} + +int fl_preferences_set_str(PREFS e, const char * k, const char * v) { + return reinterpret_cast(e)->set(k,v); +} + + + + +int fl_preferences_deleteentry(PREFS e, const char * k) { + return reinterpret_cast(e)->deleteEntry(k); +} + +int fl_preferences_deleteallentries(PREFS e) { + return reinterpret_cast(e)->deleteAllEntries(); +} + +int fl_preferences_clear(PREFS e) { + return reinterpret_cast(e)->clear(); +} + + + + +void fl_preferences_flush(PREFS e) { + reinterpret_cast(e)->flush(); +} + + diff --git a/src/c_fl_preferences.h b/src/c_fl_preferences.h new file mode 100644 index 0000000..e8581c2 --- /dev/null +++ b/src/c_fl_preferences.h @@ -0,0 +1,49 @@ + + +#ifndef FL_PREFERENCES_GUARD +#define FL_PREFERENCES_GUARD + + + + +typedef void* PREFS; + + + + +extern "C" PREFS new_fl_preferences(char * p, char * v, char * a); +extern "C" void free_fl_preferences(PREFS e); + + + + +extern "C" int fl_preferences_entries(PREFS e); +extern "C" const char * fl_preferences_entry(PREFS e, int i); +extern "C" int fl_preferences_entryexists(PREFS e, const char * k); +extern "C" int fl_preferences_size(PREFS e, const char * k); + + +extern "C" int fl_preferences_get_int(PREFS e, const char * k, int& v, int d); +extern "C" int fl_preferences_get_float(PREFS e, const char * k, float& v, float d); +extern "C" int fl_preferences_get_double(PREFS e, const char * k, double& v, double d); +extern "C" int fl_preferences_get_str(PREFS e, const char * k, char *& v, const char * d); + + +extern "C" int fl_preferences_set_int(PREFS e, const char * k, int v); +extern "C" int fl_preferences_set_float(PREFS e, const char * k, float v); +extern "C" int fl_preferences_set_float_prec(PREFS e, const char * k, float v, int p); +extern "C" int fl_preferences_set_double(PREFS e, const char * k, double v); +extern "C" int fl_preferences_set_double_prec(PREFS e, const char * k, double v, int p); +extern "C" int fl_preferences_set_str(PREFS e, const char * k, const char * v); + + +extern "C" int fl_preferences_deleteentry(PREFS e, const char * k); +extern "C" int fl_preferences_deleteallentries(PREFS e); +extern "C" int fl_preferences_clear(PREFS e); + + +extern "C" void fl_preferences_flush(PREFS e); + + +#endif + 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; + diff --git a/src/fltk-environment.ads b/src/fltk-environment.ads new file mode 100644 index 0000000..a163d19 --- /dev/null +++ b/src/fltk-environment.ads @@ -0,0 +1,163 @@ + + +package FLTK.Environment is + + + type Preferences is new Wrapper with private; + + type Scope is (Root, User); + + + + + Preference_Error : exception; + + + + + package Forge is + + function From_Filesystem + (Path, Vendor, Application : in String) + return Preferences; + + end Forge; + + + + + function Number_Of_Entries + (This : in Preferences) + return Natural; + + function Get_Key + (This : in Preferences; + Index : in Natural) + return String; + + function Entry_Exists + (This : in Preferences; + Key : in String) + return Boolean; + + function Entry_Size + (This : in Preferences; + Key : in String) + return Natural; + + + + + function Get + (This : in Preferences; + Key : in String) + return Integer; + + function Get + (This : in Preferences; + Key : in String) + return Float; + + function Get + (This : in Preferences; + Key : in String) + return Long_Float; + + function Get + (This : in Preferences; + Key : in String) + return String; + + + + + function Get + (This : in Preferences; + Key : in String; + Default : in Integer) + return Integer; + + function Get + (This : in Preferences; + Key : in String; + Default : in Float) + return Float; + + function Get + (This : in Preferences; + Key : in String; + Default : in Long_Float) + return Long_Float; + + function Get + (This : in Preferences; + Key : in String; + Default : in String) + return String; + + + + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in Integer); + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in Float); + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in Float; + Precision : in Natural); + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in Long_Float); + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in Long_Float; + Precision : in Natural); + + procedure Set + (This : in out Preferences; + Key : in String; + Value : in String); + + + + + procedure Delete_Entry + (This : in out Preferences; + Key : in String); + + procedure Delete_All_Entries + (This : in out Preferences); + + procedure Clear + (This : in out Preferences); + + + + + procedure Flush + (This : in Preferences); + + +private + + + type Preferences is new Wrapper with null record; + + overriding procedure Finalize + (This : in out Preferences); + + +end FLTK.Environment; + -- cgit