----------------------------------------------------------------------- -- util-beans-objects -- Generic Typed Data Representation -- Copyright (C) 2009, 2010, 2011, 2013, 2016, 2017, 2018, 2020, 2022 Stephane Carrez -- Written by Stephane Carrez (Stephane.Carrez@gmail.com) -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License. -- You may obtain a copy of the License at -- -- http://www.apache.org/licenses/LICENSE-2.0 -- -- Unless required by applicable law or agreed to in writing, software -- distributed under the License is distributed on an "AS IS" BASIS, -- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -- See the License for the specific language governing permissions and -- limitations under the License. ----------------------------------------------------------------------- with Ada.Characters.Conversions; with Ada.Tags; with Ada.Strings.UTF_Encoding.Wide_Wide_Strings; with Util.Beans.Basic; package body Util.Beans.Objects is use Util.Concurrent.Counters; use Ada.Characters.Conversions; function UTF8_Decode (S : in String) return Wide_Wide_String renames Ada.Strings.UTF_Encoding.Wide_Wide_Strings.Decode; -- Find the data type to be used for an arithmetic operation between two objects. function Get_Arithmetic_Type (Left, Right : Object) return Data_Type; -- Find the data type to be used for a composition operation between two objects. function Get_Compose_Type (Left, Right : Object) return Data_Type; -- Find the best type to be used to compare two operands. function Get_Compare_Type (Left, Right : Object) return Data_Type; Integer_Type : aliased constant Int_Type := Int_Type '(null record); Bool_Type : aliased constant Boolean_Type := Boolean_Type '(null record); Str_Type : aliased constant String_Type := String_Type '(null record); WString_Type : aliased constant Wide_String_Type := Wide_String_Type '(null record); Flt_Type : aliased constant Float_Type := Float_Type '(null record); Duration_Type : aliased constant Duration_Type_Def := Duration_Type_Def '(null record); Bn_Type : aliased constant Bean_Type := Bean_Type '(null record); Ar_Type : aliased constant Array_Type := Array_Type '(null record); Blob_Def : aliased constant Blob_Type := Blob_Type '(null record); -- ------------------------------ -- Convert the value into a wide string. -- ------------------------------ overriding function To_Wide_Wide_String (Type_Def : in Basic_Type; Value : in Object_Value) return Wide_Wide_String is begin return UTF8_Decode (Object_Type'Class (Type_Def).To_String (Value)); end To_Wide_Wide_String; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Basic_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def, Value); begin return 0.0; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Basic_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def, Value); begin return False; end To_Boolean; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in Basic_Type; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def, Value); begin return 0.0; end To_Duration; -- ------------------------------ -- Returns False -- ------------------------------ overriding function Is_Empty (Type_Def : in Basic_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def, Value); begin return False; end Is_Empty; -- ------------------------------ -- Null Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : Null_Type) return String is pragma Unreferenced (Type_Def); begin return "Null"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : Null_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_NULL; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Null_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def, Value); begin return "null"; end To_String; -- ------------------------------ -- Returns True -- ------------------------------ overriding function Is_Empty (Type_Def : in Null_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def, Value); begin return True; end Is_Empty; -- ------------------------------ -- Integer Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : Int_Type) return String is pragma Unreferenced (Type_Def); begin return "Integer"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : Int_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_INTEGER; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Int_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); S : constant String := Long_Long_Integer'Image (Value.Int_Value); begin if Value.Int_Value >= 0 then return S (S'First + 1 .. S'Last); else return S; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Int_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); begin return Value.Int_Value; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Int_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); begin return Long_Long_Float (Value.Int_Value); end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Int_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin return Value.Int_Value /= 0; end To_Boolean; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in Int_Type; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def); begin return Duration (Value.Int_Value); end To_Duration; -- ------------------------------ -- Float Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Float_Type) return String is pragma Unreferenced (Type_Def); begin return "Float"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Float_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_FLOAT; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Float_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin return Long_Long_Float'Image (Value.Float_Value); end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Float_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); begin return Long_Long_Integer (Value.Float_Value); end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Float_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); begin return Value.Float_Value; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Float_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin return Value.Float_Value /= 0.0; end To_Boolean; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in Float_Type; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def); begin return Duration (Value.Float_Value); end To_Duration; -- ------------------------------ -- String Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in String_Type) return String is pragma Unreferenced (Type_Def); begin return "String"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in String_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_STRING; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in String_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin if Proxy = null then return "null"; else return Proxy.Value; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in String_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin if Proxy = null then return 0; else return Long_Long_Integer'Value (Proxy.Value); end if; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in String_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin if Proxy = null then return 0.0; else return Long_Long_Float'Value (Proxy.Value); end if; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in String_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin return Proxy /= null and then (Proxy.Value = "true" or else Proxy.Value = "TRUE" or else Proxy.Value = "1"); end To_Boolean; -- ------------------------------ -- Returns True if the value is empty. -- ------------------------------ overriding function Is_Empty (Type_Def : in String_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin return Proxy = null or else Proxy.Value = ""; end Is_Empty; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in String_Type; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def); Proxy : constant String_Proxy_Access := Value.String_Proxy; begin if Proxy = null then return 0.0; else return Duration'Value (Proxy.Value); end if; end To_Duration; -- ------------------------------ -- Wide String Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Wide_String_Type) return String is pragma Unreferenced (Type_Def); begin return "WideString"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Wide_String_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_WIDE_STRING; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Wide_String_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin if Proxy = null then return "null"; else return To_String (Proxy.Value); end if; end To_String; -- ------------------------------ -- Convert the value into a wide string. -- ------------------------------ overriding function To_Wide_Wide_String (Type_Def : in Wide_String_Type; Value : in Object_Value) return Wide_Wide_String is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin if Proxy = null then return "null"; else return Proxy.Value; end if; end To_Wide_Wide_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Wide_String_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin if Proxy = null then return 0; else return Long_Long_Integer'Value (To_String (Proxy.Value)); end if; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Wide_String_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin if Proxy = null then return 0.0; else return Long_Long_Float'Value (To_String (Proxy.Value)); end if; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Wide_String_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin return Proxy /= null and then (Proxy.Value = "true" or else Proxy.Value = "TRUE" or else Proxy.Value = "1"); end To_Boolean; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in Wide_String_Type; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin if Proxy = null then return 0.0; else return Duration'Value (To_String (Proxy.Value)); end if; end To_Duration; -- ------------------------------ -- Returns True if the value is empty. -- ------------------------------ overriding function Is_Empty (Type_Def : in Wide_String_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Wide_String_Proxy_Access := Value.Wide_Proxy; begin return Proxy = null or else Proxy.Value = ""; end Is_Empty; -- ------------------------------ -- Boolean Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Boolean_Type) return String is pragma Unreferenced (Type_Def); begin return "Boolean"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Boolean_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_BOOLEAN; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Boolean_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin if Value.Bool_Value then return "TRUE"; else return "FALSE"; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Boolean_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); begin if Value.Bool_Value then return 1; else return 0; end if; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Boolean_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); begin if Value.Bool_Value then return 1.0; else return 0.0; end if; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Boolean_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin return Value.Bool_Value; end To_Boolean; -- ------------------------------ -- Duration Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Duration_Type_Def) return String is pragma Unreferenced (Type_Def); begin return "Duration"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Duration_Type_Def) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_TIME; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Duration_Type_Def; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin return Duration'Image (Value.Time_Value); end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Duration_Type_Def; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def); begin return Long_Long_Integer (Value.Time_Value); end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Duration_Type_Def; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def); begin return Long_Long_Float (Value.Time_Value); end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Duration_Type_Def; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin return Value.Time_Value > 0.0; end To_Boolean; -- ------------------------------ -- Convert the value into a duration. -- ------------------------------ overriding function To_Duration (Type_Def : in Duration_Type_Def; Value : in Object_Value) return Duration is pragma Unreferenced (Type_Def); begin return Value.Time_Value; end To_Duration; -- ------------------------------ -- Bean Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Bean_Type) return String is pragma Unreferenced (Type_Def); begin return "Bean"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Bean_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_BEAN; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Bean_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin if Value.Proxy = null or else Value.Proxy.Bean = null then return ""; else return "<" & Ada.Tags.Expanded_Name (Value.Proxy.Bean'Tag) & ">"; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Bean_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def, Value); begin return 0; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Bean_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def, Value); begin return 0.0; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Bean_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Bean_Proxy_Access := Value.Proxy; begin return Proxy /= null; end To_Boolean; -- ------------------------------ -- Returns True if the value is empty. -- ------------------------------ overriding function Is_Empty (Type_Def : in Bean_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Bean_Proxy_Access := Value.Proxy; begin if Proxy = null then return True; end if; if not (Proxy.all in Bean_Proxy'Class) then return False; end if; if not (Proxy.Bean.all in Util.Beans.Basic.List_Bean'Class) then return False; end if; declare L : constant Util.Beans.Basic.List_Bean_Access := Beans.Basic.List_Bean'Class (Proxy.Bean.all)'Unchecked_Access; begin return L.Get_Count = 0; end; end Is_Empty; -- ------------------------------ -- Blob Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Blob_Type) return String is pragma Unreferenced (Type_Def); begin return "Blob"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Blob_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_BLOB; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Blob_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin if Value.Blob_Proxy = null then return ""; else return ""; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Blob_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def, Value); begin return 0; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Blob_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def, Value); begin return 0.0; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Blob_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Blob_Proxy_Access := Value.Blob_Proxy; begin return Proxy /= null; end To_Boolean; -- ------------------------------ -- Returns True if the value is empty. -- ------------------------------ overriding function Is_Empty (Type_Def : in Blob_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin if Value.Blob_Proxy = null then return True; else return Value.Blob_Proxy.Blob.Is_Null; end if; end Is_Empty; -- ------------------------------ -- Array Type -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ overriding function Get_Name (Type_Def : in Array_Type) return String is pragma Unreferenced (Type_Def); begin return "Array"; end Get_Name; -- ------------------------------ -- Get the base data type. -- ------------------------------ overriding function Get_Data_Type (Type_Def : in Array_Type) return Data_Type is pragma Unreferenced (Type_Def); begin return TYPE_ARRAY; end Get_Data_Type; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_String (Type_Def : in Array_Type; Value : in Object_Value) return String is pragma Unreferenced (Type_Def); begin if Value.Array_Proxy = null then return ""; else return ""; end if; end To_String; -- ------------------------------ -- Convert the value into an integer. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Array_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def, Value); begin return 0; end To_Long_Long; -- ------------------------------ -- Convert the value into a float. -- ------------------------------ overriding function To_Long_Float (Type_Def : in Array_Type; Value : in Object_Value) return Long_Long_Float is pragma Unreferenced (Type_Def, Value); begin return 0.0; end To_Long_Float; -- ------------------------------ -- Convert the value into a boolean. -- ------------------------------ overriding function To_Boolean (Type_Def : in Array_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); Proxy : constant Array_Proxy_Access := Value.Array_Proxy; begin return Proxy /= null; end To_Boolean; -- ------------------------------ -- Returns True if the value is empty. -- ------------------------------ overriding function Is_Empty (Type_Def : in Array_Type; Value : in Object_Value) return Boolean is pragma Unreferenced (Type_Def); begin if Value.Array_Proxy = null then return True; else return Value.Array_Proxy.Len = 0; end if; end Is_Empty; -- ------------------------------ -- Convert the value into a string. -- ------------------------------ overriding function To_Long_Long (Type_Def : in Basic_Type; Value : in Object_Value) return Long_Long_Integer is pragma Unreferenced (Type_Def, Value); begin return 0; end To_Long_Long; -- ------------------------------ -- Check whether the object contains a value. -- Returns true if the object does not contain a value. -- ------------------------------ function Is_Null (Value : in Object) return Boolean is begin return Value.V.Of_Type = TYPE_NULL; end Is_Null; -- ------------------------------ -- Check whether the object is empty. -- If the object is null, returns true. -- If the object is the empty string, returns true. -- If the object is a list bean whose Get_Count is 0, returns true. -- Otherwise returns false. -- ------------------------------ function Is_Empty (Value : in Object) return Boolean is begin return Value.Type_Def.Is_Empty (Value.V); end Is_Empty; function Get_Array_Bean (Value : in Object) return access Util.Beans.Basic.Array_Bean'Class is Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (Value); begin if Bean = null or else not (Bean.all in Util.Beans.Basic.Array_Bean'Class) then return null; else return Util.Beans.Basic.Array_Bean'Class (Bean.all)'Unchecked_Access; end if; end Get_Array_Bean; -- ------------------------------ -- Returns True if the object is an array. -- ------------------------------ function Is_Array (Value : in Object) return Boolean is begin if Value.V.Of_Type = TYPE_ARRAY then return True; elsif Value.V.Of_Type /= TYPE_BEAN then return False; else return Get_Array_Bean (Value) /= null; end if; end Is_Array; -- ------------------------------ -- Generic Object holding a value -- ------------------------------ -- ------------------------------ -- Get the type name -- ------------------------------ function Get_Type_Name (Value : in Object) return String is begin return Value.Type_Def.Get_Name; end Get_Type_Name; -- ------------------------------ -- Get a type identification for the object value. -- ------------------------------ function Get_Type (Value : in Object) return Data_Type is begin return Value.V.Of_Type; end Get_Type; -- ------------------------------ -- Get the type definition of the object value. -- ------------------------------ function Get_Type (Value : Object) return Object_Type_Access is begin return Value.Type_Def; end Get_Type; -- ------------------------------ -- Get the value identified by the name in the bean object. -- If the value object is not a bean, returns the null object. -- ------------------------------ function Get_Value (Value : in Object; Name : in String) return Object is Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (Value); begin if Bean = null then return Null_Object; else return Bean.Get_Value (Name); end if; end Get_Value; -- ------------------------------ -- Set into the target object a value identified by the name. -- The target object must be a Bean instance that implements the Set_Value -- procedure. The operation does nothing if this is not the case. -- ------------------------------ procedure Set_Value (Into : in Object; Name : in String; Value : in Object) is Bean : constant access Util.Beans.Basic.Readonly_Bean'Class := To_Bean (Into); begin if Bean /= null and then Bean.all in Util.Beans.Basic.Bean'Class then Util.Beans.Basic.Bean'Class (Bean.all).Set_Value (Name, Value); end if; end Set_Value; -- ------------------------------ -- Get the number of elements in the array object. -- Returns 0 if the object is not an array. -- ------------------------------ function Get_Count (From : in Object) return Natural is use type Util.Beans.Basic.Array_Bean_Access; Bean : Util.Beans.Basic.Array_Bean_Access; begin if From.V.Of_Type = TYPE_ARRAY then return From.V.Array_Proxy.Len; elsif From.V.Of_Type /= TYPE_BEAN or else From.V.Proxy = null then return 0; else Bean := Get_Array_Bean (From); if Bean = null then return 0; else return Bean.Get_Count; end if; end if; end Get_Count; -- ------------------------------ -- Get the array element at the given position. -- ------------------------------ function Get_Value (From : in Object; Position : in Positive) return Object is use type Util.Beans.Basic.Array_Bean_Access; Bean : Util.Beans.Basic.Array_Bean_Access; begin if From.V.Of_Type = TYPE_BEAN then Bean := Get_Array_Bean (From); if Bean /= null then return Bean.Get_Row (Position); else return Null_Object; end if; elsif From.V.Of_Type /= TYPE_ARRAY then return Null_Object; elsif From.V.Array_Proxy.Len < Position then return Null_Object; else return From.V.Array_Proxy.Values (Position); end if; end Get_Value; -- ------------------------------ -- Convert the object to the corresponding type. -- ------------------------------ function To_String (Value : Object) return String is begin return Value.Type_Def.To_String (Value.V); end To_String; -- ------------------------------ -- Convert the object to a wide string. -- ------------------------------ function To_Wide_Wide_String (Value : Object) return Wide_Wide_String is begin return Value.Type_Def.To_Wide_Wide_String (Value.V); end To_Wide_Wide_String; -- ------------------------------ -- Convert the object to an unbounded string. -- ------------------------------ function To_Unbounded_String (Value : Object) return Unbounded_String is begin case Value.V.Of_Type is when TYPE_STRING => if Value.V.String_Proxy = null then return To_Unbounded_String ("null"); end if; return To_Unbounded_String (Value.V.String_Proxy.Value); when others => return To_Unbounded_String (To_String (Value)); end case; end To_Unbounded_String; -- ------------------------------ -- Convert the object to an unbounded wide string. -- ------------------------------ function To_Unbounded_Wide_Wide_String (Value : Object) return Unbounded_Wide_Wide_String is begin case Value.V.Of_Type is when TYPE_WIDE_STRING => if Value.V.Wide_Proxy = null then return To_Unbounded_Wide_Wide_String ("null"); end if; return To_Unbounded_Wide_Wide_String (Value.V.Wide_Proxy.Value); when TYPE_STRING => if Value.V.String_Proxy = null then return To_Unbounded_Wide_Wide_String ("null"); end if; return To_Unbounded_Wide_Wide_String (UTF8_Decode (Value.V.String_Proxy.Value)); when others => return To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (To_String (Value))); end case; end To_Unbounded_Wide_Wide_String; -- ------------------------------ -- Convert the object to an integer. -- ------------------------------ function To_Integer (Value : Object) return Integer is begin return Integer (Value.Type_Def.To_Long_Long (Value.V)); end To_Integer; -- ------------------------------ -- Convert the object to an integer. -- ------------------------------ function To_Long_Integer (Value : Object) return Long_Integer is begin return Long_Integer (Value.Type_Def.To_Long_Long (Value.V)); end To_Long_Integer; -- ------------------------------ -- Convert the object to a long integer. -- ------------------------------ function To_Long_Long_Integer (Value : Object) return Long_Long_Integer is begin return Value.Type_Def.To_Long_Long (Value.V); end To_Long_Long_Integer; -- ------------------------------ -- Convert the object to a duration. -- ------------------------------ function To_Duration (Value : in Object) return Duration is begin return Value.Type_Def.To_Duration (Value.V); end To_Duration; function To_Bean (Value : in Object) return access Util.Beans.Basic.Readonly_Bean'Class is begin if Value.V.Of_Type = TYPE_BEAN and then Value.V.Proxy /= null then return Value.V.Proxy.Bean; else return null; end if; end To_Bean; -- ------------------------------ -- Convert the object to a boolean. -- ------------------------------ function To_Boolean (Value : Object) return Boolean is begin return Value.Type_Def.To_Boolean (Value.V); end To_Boolean; -- ------------------------------ -- Convert the object to a float. -- ------------------------------ function To_Float (Value : Object) return Float is begin return Float (Value.Type_Def.To_Long_Float (Value.V)); end To_Float; -- ------------------------------ -- Convert the object to a long float. -- ------------------------------ function To_Long_Float (Value : Object) return Long_Float is begin return Long_Float (Value.Type_Def.To_Long_Float (Value.V)); end To_Long_Float; -- ------------------------------ -- Convert the object to a long float. -- ------------------------------ function To_Long_Long_Float (Value : Object) return Long_Long_Float is begin return Value.Type_Def.To_Long_Float (Value.V); end To_Long_Long_Float; -- ------------------------------ -- Convert the object to a long float. -- ------------------------------ function To_Blob (Value : Object) return Util.Blobs.Blob_Ref is begin if Value.V.Of_Type = TYPE_BLOB and then Value.V.Blob_Proxy /= null then return Value.V.Blob_Proxy.Blob; else return Util.Blobs.Null_Blob; end if; end To_Blob; -- ------------------------------ -- Convert an integer into a generic typed object. -- ------------------------------ function To_Object (Value : Integer) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_INTEGER, Int_Value => Long_Long_Integer (Value)), Type_Def => Integer_Type'Access); end To_Object; -- ------------------------------ -- Convert an integer into a generic typed object. -- ------------------------------ function To_Object (Value : Long_Integer) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_INTEGER, Int_Value => Long_Long_Integer (Value)), Type_Def => Integer_Type'Access); end To_Object; -- ------------------------------ -- Convert an integer into a generic typed object. -- ------------------------------ function To_Object (Value : Long_Long_Integer) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_INTEGER, Int_Value => Value), Type_Def => Integer_Type'Access); end To_Object; -- ------------------------------ -- Convert a boolean into a generic typed object. -- ------------------------------ function To_Object (Value : Boolean) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_BOOLEAN, Bool_Value => Value), Type_Def => Bool_Type'Access); end To_Object; -- ------------------------------ -- Convert a float into a generic typed object. -- ------------------------------ function To_Object (Value : Float) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_FLOAT, Float_Value => Long_Long_Float (Value)), Type_Def => Flt_Type'Access); end To_Object; -- ------------------------------ -- Convert a long float into a generic typed object. -- ------------------------------ function To_Object (Value : Long_Float) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_FLOAT, Float_Value => Long_Long_Float (Value)), Type_Def => Flt_Type'Access); end To_Object; -- ------------------------------ -- Convert a long long float into a generic typed object. -- ------------------------------ function To_Object (Value : Long_Long_Float) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_FLOAT, Float_Value => Value), Type_Def => Flt_Type'Access); end To_Object; -- ------------------------------ -- Convert a duration into a generic typed object. -- ------------------------------ function To_Object (Value : in Duration) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_TIME, Time_Value => Value), Type_Def => Duration_Type'Access); end To_Object; -- ------------------------------ -- Convert a string into a generic typed object. -- ------------------------------ function To_Object (Value : String) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_STRING, String_Proxy => new String_Proxy '(Ref_Counter => ONE, Len => Value'Length, Value => Value)), Type_Def => Str_Type'Access); end To_Object; -- ------------------------------ -- Convert a wide string into a generic typed object. -- ------------------------------ function To_Object (Value : Wide_Wide_String) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_WIDE_STRING, Wide_Proxy => new Wide_String_Proxy '(Ref_Counter => ONE, Len => Value'Length, Value => Value)), Type_Def => WString_Type'Access); end To_Object; -- ------------------------------ -- Convert an unbounded string into a generic typed object. -- ------------------------------ function To_Object (Value : Unbounded_String) return Object is Len : constant Natural := Length (Value); begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_STRING, String_Proxy => new String_Proxy '(Ref_Counter => ONE, Len => Len, Value => To_String (Value))), Type_Def => Str_Type'Access); end To_Object; -- ------------------------------ -- Convert a unbounded wide string into a generic typed object. -- ------------------------------ function To_Object (Value : Unbounded_Wide_Wide_String) return Object is Len : constant Natural := Length (Value); begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_WIDE_STRING, Wide_Proxy => new Wide_String_Proxy '(Ref_Counter => ONE, Len => Len, Value => To_Wide_Wide_String (Value))), Type_Def => WString_Type'Access); end To_Object; function To_Object (Value : access Util.Beans.Basic.Readonly_Bean'Class; Storage : in Storage_Type := DYNAMIC) return Object is begin if Value = null then return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_BEAN, Proxy => null), Type_Def => Bn_Type'Access); else return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_BEAN, Proxy => new Bean_Proxy '(Ref_Counter => ONE, Bean => Value, Storage => Storage)), Type_Def => Bn_Type'Access); end if; end To_Object; function To_Object (Value : in Object_Array) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_ARRAY, Array_Proxy => new Array_Proxy '(Ref_Counter => ONE, Len => Value'Length, Count => Value'Length, Values => Value)), Type_Def => Ar_Type'Access); end To_Object; function To_Object (Value : in Util.Blobs.Blob_Ref) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_BLOB, Blob_Proxy => new Blob_Proxy '(Ref_Counter => ONE, Blob => Value)), Type_Def => Blob_Def'Access); end To_Object; -- ------------------------------ -- Convert the object to an object of another time. -- Force the object to be an integer. -- ------------------------------ function Cast_Integer (Value : Object) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_INTEGER, Int_Value => Value.Type_Def.To_Long_Long (Value.V)), Type_Def => Integer_Type'Access); end Cast_Integer; -- ------------------------------ -- Force the object to be a float. -- ------------------------------ function Cast_Float (Value : Object) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_FLOAT, Float_Value => Value.Type_Def.To_Long_Float (Value.V)), Type_Def => Flt_Type'Access); end Cast_Float; -- ------------------------------ -- Convert the object to an object of another time. -- Force the object to be a duration. -- ------------------------------ function Cast_Duration (Value : Object) return Object is begin return Object '(Controlled with V => Object_Value '(Of_Type => TYPE_TIME, Time_Value => Value.Type_Def.To_Duration (Value.V)), Type_Def => Duration_Type'Access); end Cast_Duration; -- ------------------------------ -- Force the object to be a string. -- ------------------------------ function Cast_String (Value : Object) return Object is begin if Value.V.Of_Type = TYPE_STRING or else Value.V.Of_Type = TYPE_WIDE_STRING then return Value; else return To_Object (To_Wide_Wide_String (Value)); end if; end Cast_String; -- ------------------------------ -- Find the best type to be used to compare two operands. -- -- ------------------------------ function Get_Compare_Type (Left, Right : Object) return Data_Type is begin -- Operands are of the same type. if Left.V.Of_Type = Right.V.Of_Type then return Left.V.Of_Type; end if; -- 12 >= "23" -- if Left.Of_Type = TYPE_STRING or case Left.V.Of_Type is when TYPE_BOOLEAN => case Right.V.Of_Type is when TYPE_INTEGER | TYPE_BOOLEAN | TYPE_TIME => return TYPE_INTEGER; when TYPE_FLOAT | TYPE_STRING | TYPE_WIDE_STRING => return Right.V.Of_Type; when others => null; end case; when TYPE_INTEGER => case Right.V.Of_Type is when TYPE_BOOLEAN | TYPE_TIME => return TYPE_INTEGER; when TYPE_FLOAT => return TYPE_FLOAT; when others => null; end case; when TYPE_TIME => case Right.V.Of_Type is when TYPE_INTEGER | TYPE_BOOLEAN | TYPE_FLOAT => return TYPE_INTEGER; when others => null; end case; when TYPE_FLOAT => case Right.V.Of_Type is when TYPE_INTEGER | TYPE_BOOLEAN => return TYPE_FLOAT; when TYPE_TIME => return TYPE_INTEGER; when others => null; end case; when others => null; end case; return TYPE_STRING; end Get_Compare_Type; -- ------------------------------ -- Find the data type to be used for an arithmetic operation between two objects. -- ------------------------------ function Get_Arithmetic_Type (Left, Right : Object) return Data_Type is begin if Left.V.Of_Type = TYPE_FLOAT or else Right.V.Of_Type = TYPE_FLOAT then return TYPE_FLOAT; end if; if Left.V.Of_Type = TYPE_INTEGER or else Right.V.Of_Type = TYPE_INTEGER then return TYPE_INTEGER; end if; if Left.V.Of_Type = TYPE_BOOLEAN and then Right.V.Of_Type = TYPE_BOOLEAN then return TYPE_BOOLEAN; end if; return TYPE_FLOAT; end Get_Arithmetic_Type; -- ------------------------------ -- Find the data type to be used for a composition operation between two objects. -- ------------------------------ function Get_Compose_Type (Left, Right : Object) return Data_Type is begin if Left.V.Of_Type = Right.V.Of_Type then return Left.V.Of_Type; end if; if Left.V.Of_Type = TYPE_FLOAT or else Right.V.Of_Type = TYPE_FLOAT then return TYPE_FLOAT; end if; if Left.V.Of_Type = TYPE_INTEGER or else Right.V.Of_Type = TYPE_INTEGER then return TYPE_INTEGER; end if; if Left.V.Of_Type = TYPE_TIME or else Right.V.Of_Type = TYPE_TIME then return TYPE_TIME; end if; if Left.V.Of_Type = TYPE_BOOLEAN and then Right.V.Of_Type = TYPE_BOOLEAN then return TYPE_BOOLEAN; end if; return TYPE_FLOAT; end Get_Compose_Type; -- ------------------------------ -- Comparison of objects -- ------------------------------ generic with function Int_Comparator (Left, Right : Long_Long_Integer) return Boolean; with function Time_Comparator (Left, Right : Duration) return Boolean; with function Boolean_Comparator (Left, Right : Boolean) return Boolean; with function Float_Comparator (Left, Right : Long_Long_Float) return Boolean; with function String_Comparator (Left, Right : String) return Boolean; with function Wide_String_Comparator (Left, Right : Wide_Wide_String) return Boolean; function Compare (Left, Right : Object) return Boolean; -- ------------------------------ -- Comparison of objects -- ------------------------------ function Compare (Left, Right : Object) return Boolean is T : constant Data_Type := Get_Compare_Type (Left, Right); begin case T is when TYPE_BOOLEAN => return Boolean_Comparator (Left.Type_Def.To_Boolean (Left.V), Right.Type_Def.To_Boolean (Right.V)); when TYPE_INTEGER => return Int_Comparator (Left.Type_Def.To_Long_Long (Left.V), Right.Type_Def.To_Long_Long (Right.V)); when TYPE_TIME => return Time_Comparator (Left.Type_Def.To_Duration (Left.V), Right.Type_Def.To_Duration (Right.V)); when TYPE_FLOAT => return Float_Comparator (Left.Type_Def.To_Long_Float (Left.V), Right.Type_Def.To_Long_Float (Right.V)); when TYPE_STRING => return String_Comparator (To_String (Left), To_String (Right)); when TYPE_WIDE_STRING => return Wide_String_Comparator (To_Wide_Wide_String (Left), To_Wide_Wide_String (Right)); when others => return False; end case; end Compare; function ">" (Left, Right : Object) return Boolean is function Cmp is new Compare (Int_Comparator => ">", Time_Comparator => ">", Boolean_Comparator => ">", Float_Comparator => ">", String_Comparator => ">", Wide_String_Comparator => ">"); begin return Cmp (Left, Right); end ">"; function "<" (Left, Right : Object) return Boolean is function Cmp is new Compare (Int_Comparator => "<", Time_Comparator => "<", Boolean_Comparator => "<", Float_Comparator => "<", String_Comparator => "<", Wide_String_Comparator => "<"); begin return Cmp (Left, Right); end "<"; function "<=" (Left, Right : Object) return Boolean is function Cmp is new Compare (Int_Comparator => "<=", Time_Comparator => "<=", Boolean_Comparator => "<=", Float_Comparator => "<=", String_Comparator => "<=", Wide_String_Comparator => "<="); begin return Cmp (Left, Right); end "<="; function ">=" (Left, Right : Object) return Boolean is function Cmp is new Compare (Int_Comparator => ">=", Time_Comparator => ">=", Boolean_Comparator => ">=", Float_Comparator => ">=", String_Comparator => ">=", Wide_String_Comparator => ">="); begin return Cmp (Left, Right); end ">="; overriding function "=" (Left, Right : Object) return Boolean is function Cmp is new Compare (Int_Comparator => "=", Time_Comparator => "=", Boolean_Comparator => "=", Float_Comparator => "=", String_Comparator => "=", Wide_String_Comparator => "="); begin return Cmp (Left, Right); end "="; -- ------------------------------ -- Arithmetic operations of objects -- ------------------------------ generic with function Int_Operation (Left, Right : Long_Long_Integer) return Long_Long_Integer; with function Duration_Operation (Left, Right : Duration) return Duration; with function Float_Operation (Left, Right : Long_Long_Float) return Long_Long_Float; function Arith (Left, Right : Object) return Object; -- Comparison of objects function Arith (Left, Right : Object) return Object is begin -- If we have a time object, keep the time definition. if Left.V.Of_Type = TYPE_TIME then return Result : Object do Result.Type_Def := Left.Type_Def; Result.V := Object_Value '(Of_Type => TYPE_TIME, Time_Value => Duration_Operation (Left.Type_Def.To_Duration (Left.V), Right.Type_Def.To_Duration (Right.V))); end return; end if; if Right.V.Of_Type = TYPE_TIME then return Result : Object do Result.Type_Def := Right.Type_Def; Result.V := Object_Value '(Of_Type => TYPE_TIME, Time_Value => Duration_Operation (Left.Type_Def.To_Duration (Left.V), Right.Type_Def.To_Duration (Right.V))); end return; end if; declare T : constant Data_Type := Get_Arithmetic_Type (Left, Right); begin case T is when TYPE_INTEGER => return To_Object (Int_Operation (Left.Type_Def.To_Long_Long (Left.V), Right.Type_Def.To_Long_Long (Right.V))); when TYPE_FLOAT => return To_Object (Float_Operation (Left.Type_Def.To_Long_Float (Left.V), Right.Type_Def.To_Long_Float (Right.V))); when others => return Left; end case; end; end Arith; -- Arithmetic operations on objects function "+" (Left, Right : Object) return Object is function Operation is new Arith (Int_Operation => "+", Duration_Operation => "+", Float_Operation => "+"); begin return Operation (Left, Right); end "+"; function "-" (Left, Right : Object) return Object is function Operation is new Arith (Int_Operation => "-", Duration_Operation => "-", Float_Operation => "-"); begin return Operation (Left, Right); end "-"; function "-" (Left : Object) return Object is begin case Left.V.Of_Type is when TYPE_INTEGER => return To_Object (-Left.Type_Def.To_Long_Long (Left.V)); when TYPE_TIME => return To_Object (-Left.Type_Def.To_Duration (Left.V)); when TYPE_FLOAT => return To_Object (-(Left.Type_Def.To_Long_Float (Left.V))); when others => return Left; end case; end "-"; function "*" (Left, Right : Object) return Object is function Operation is new Arith (Int_Operation => "*", Duration_Operation => "+", Float_Operation => "*"); begin return Operation (Left, Right); end "*"; function "/" (Left, Right : Object) return Object is function Operation is new Arith (Int_Operation => "/", Duration_Operation => "-", Float_Operation => "/"); begin return Operation (Left, Right); end "/"; function "mod" (Left, Right : Object) return Object is function "mod" (Left, Right : Long_Long_Float) return Long_Long_Float; function "mod" (Left, Right : Long_Long_Float) return Long_Long_Float is L : constant Long_Long_Integer := Long_Long_Integer (Left); R : constant Long_Long_Integer := Long_Long_Integer (Right); begin return Long_Long_Float (L mod R); end "mod"; function Operation is new Arith (Int_Operation => "mod", Duration_Operation => "-", Float_Operation => "mod"); begin return Operation (Left, Right); end "mod"; function "&" (Left, Right : Object) return Object is T : constant Data_Type := Get_Compose_Type (Left, Right); begin case T is when TYPE_BOOLEAN => return To_Object (To_Boolean (Left) and then To_Boolean (Right)); when others => return To_Object (To_String (Left) & To_String (Right)); end case; end "&"; overriding procedure Adjust (Obj : in out Object) is begin case Obj.V.Of_Type is when TYPE_BEAN => if Obj.V.Proxy /= null then Util.Concurrent.Counters.Increment (Obj.V.Proxy.Ref_Counter); end if; when TYPE_ARRAY => if Obj.V.Array_Proxy /= null then Util.Concurrent.Counters.Increment (Obj.V.Array_Proxy.Ref_Counter); end if; when TYPE_STRING => if Obj.V.String_Proxy /= null then Util.Concurrent.Counters.Increment (Obj.V.String_Proxy.Ref_Counter); end if; when TYPE_WIDE_STRING => if Obj.V.Wide_Proxy /= null then Util.Concurrent.Counters.Increment (Obj.V.Wide_Proxy.Ref_Counter); end if; when TYPE_BLOB => if Obj.V.Blob_Proxy /= null then Util.Concurrent.Counters.Increment (Obj.V.Blob_Proxy.Ref_Counter); end if; when others => null; end case; end Adjust; procedure Free is new Ada.Unchecked_Deallocation (Object => Basic.Readonly_Bean'Class, Name => Basic.Readonly_Bean_Access); procedure Free is new Ada.Unchecked_Deallocation (Object => Array_Proxy, Name => Array_Proxy_Access); procedure Free is new Ada.Unchecked_Deallocation (Object => String_Proxy, Name => String_Proxy_Access); procedure Free is new Ada.Unchecked_Deallocation (Object => Wide_String_Proxy, Name => Wide_String_Proxy_Access); procedure Free is new Ada.Unchecked_Deallocation (Object => Blob_Proxy, Name => Blob_Proxy_Access); overriding procedure Finalize (Obj : in out Object) is Release : Boolean; begin case Obj.V.Of_Type is when TYPE_STRING => if Obj.V.String_Proxy /= null then Util.Concurrent.Counters.Decrement (Obj.V.String_Proxy.Ref_Counter, Release); if Release then Free (Obj.V.String_Proxy); else Obj.V.String_Proxy := null; end if; end if; when TYPE_WIDE_STRING => if Obj.V.Wide_Proxy /= null then Util.Concurrent.Counters.Decrement (Obj.V.Wide_Proxy.Ref_Counter, Release); if Release then Free (Obj.V.Wide_Proxy); else Obj.V.Wide_Proxy := null; end if; end if; when TYPE_BEAN => if Obj.V.Proxy /= null then Util.Concurrent.Counters.Decrement (Obj.V.Proxy.Ref_Counter, Release); if Release then Obj.V.Proxy.all.Release; Free (Obj.V.Proxy); else Obj.V.Proxy := null; end if; end if; when TYPE_ARRAY => if Obj.V.Array_Proxy /= null then Util.Concurrent.Counters.Decrement (Obj.V.Array_Proxy.Ref_Counter, Release); if Release then Free (Obj.V.Array_Proxy); else Obj.V.Array_Proxy := null; end if; end if; when TYPE_BLOB => if Obj.V.Blob_Proxy /= null then Util.Concurrent.Counters.Decrement (Obj.V.Blob_Proxy.Ref_Counter, Release); if Release then Free (Obj.V.Blob_Proxy); else Obj.V.Blob_Proxy := null; end if; end if; when others => null; end case; end Finalize; -- ------------------------------ -- Release the object pointed to by the proxy (if necessary). -- ------------------------------ overriding procedure Release (P : in out Bean_Proxy) is begin if P.Storage = DYNAMIC and then P.Bean /= null then declare Bean : Basic.Readonly_Bean_Access := P.Bean.all'Access; begin P.Bean := null; Free (Bean); end; end if; end Release; overriding procedure Finalize (Proxy : in out Proxy_Iterator) is Release : Boolean; begin if Proxy.Proxy /= null then Util.Concurrent.Counters.Decrement (Proxy.Proxy.Ref_Counter, Release); if Release then Free (Proxy.Proxy); else Proxy.Proxy := null; end if; end if; end Finalize; end Util.Beans.Objects;