----------------------------------------------------------------------- -- ADO Objects -- Database objects -- Copyright (C) 2009 - 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.Strings.Unbounded.Hash; with Ada.Unchecked_Deallocation; with ADO.Sessions.Factory; package body ADO.Objects is use type ADO.Schemas.Class_Mapping_Access; -- ------------------------------ -- Compute the hash of the object key. -- ------------------------------ function Hash (Key : Object_Key) return Ada.Containers.Hash_Type is use Ada.Containers; Result : Ada.Containers.Hash_Type; begin case Key.Of_Type is when KEY_INTEGER => if Key.Id < 0 then Result := Hash_Type (-Key.Id); else Result := Hash_Type (Key.Id); end if; when KEY_STRING => Result := Ada.Strings.Unbounded.Hash (Key.Str); end case; -- Merge with the class mapping hash so that two key values of different -- tables will result in a different hash. Result := Result xor ADO.Schemas.Hash (Key.Of_Class); return Result; end Hash; -- ------------------------------ -- Compare whether the two objects pointed to by Left and Right have the same -- object key. The object key is identical if the object key type, the class -- mapping and the key value are identical. -- ------------------------------ function Equivalent_Elements (Left, Right : Object_Key) return Boolean is use Ada.Strings.Unbounded; begin if Left.Of_Type /= Right.Of_Type then return False; end if; if Left.Of_Class /= Right.Of_Class then return False; end if; case Left.Of_Type is when KEY_INTEGER => return Left.Id = Right.Id; when KEY_STRING => return Left.Str = Right.Str; end case; end Equivalent_Elements; -- ------------------------------ -- Get the key value -- ------------------------------ function Get_Value (Key : Object_Key) return Identifier is begin return Key.Id; end Get_Value; -- ------------------------------ -- Get the key value -- ------------------------------ function Get_Value (Key : Object_Key) return Ada.Strings.Unbounded.Unbounded_String is begin return Key.Str; end Get_Value; -- ------------------------------ -- Set the key value -- ------------------------------ procedure Set_Value (Key : in out Object_Key; Value : in Identifier) is begin case Key.Of_Type is when KEY_INTEGER => Key.Id := Value; when KEY_STRING => Key.Str := Ada.Strings.Unbounded.To_Unbounded_String (Identifier'Image (Value)); end case; end Set_Value; -- ------------------------------ -- Set the key value -- ------------------------------ procedure Set_Value (Key : in out Object_Key; Value : in String) is begin case Key.Of_Type is when KEY_INTEGER => Key.Id := Identifier'Value (Value); when KEY_STRING => Key.Str := Ada.Strings.Unbounded.To_Unbounded_String (Value); end case; end Set_Value; -- ------------------------------ -- Get the key as a string -- ------------------------------ function To_String (Key : Object_Key) return String is begin case Key.Of_Type is when KEY_INTEGER => return Identifier'Image (Key.Id); when KEY_STRING => return Ada.Strings.Unbounded.To_String (Key.Str); end case; end To_String; -- ------------------------------ -- Return the key value in a bean object. -- ------------------------------ function To_Object (Key : Object_Key) return Util.Beans.Objects.Object is begin case Key.Of_Type is when KEY_INTEGER => return Util.Beans.Objects.To_Object (Long_Long_Integer (Key.Id)); when KEY_STRING => return Util.Beans.Objects.To_Object (Key.Str); end case; end To_Object; -- ------------------------------ -- Increment the reference counter when an object is copied -- ------------------------------ overriding procedure Adjust (Object : in out Object_Ref) is begin if Object.Object /= null then Util.Concurrent.Counters.Increment (Object.Object.Counter); end if; end Adjust; -- ------------------------------ -- Decrement the reference counter and release the object record. -- ------------------------------ overriding procedure Finalize (Object : in out Object_Ref) is procedure Free is new Ada.Unchecked_Deallocation (Object => Object_Record'Class, Name => Object_Record_Access); Is_Zero : Boolean; begin if Object.Object /= null then Util.Concurrent.Counters.Decrement (Object.Object.Counter, Is_Zero); if Is_Zero then Free (Object.Object); end if; end if; end Finalize; -- ------------------------------ -- Mark the field identified by Field as modified. -- ------------------------------ procedure Set_Field (Object : in out Object_Ref'Class; Field : in Column_Index) is begin if Object.Object = null then Object.Allocate; Object.Object.Is_Loaded := True; elsif not Object.Object.Is_Loaded then Object.Lazy_Load; end if; Object.Object.Modified (Field) := True; end Set_Field; -- ------------------------------ -- Prepare the object to be modified. If the reference is empty, an object record -- instance is allocated by calling Allocate. -- ------------------------------ procedure Prepare_Modify (Object : in out Object_Ref'Class; Result : out Object_Record_Access) is begin if Object.Object = null then Object.Allocate; Object.Object.Is_Loaded := True; elsif not Object.Object.Is_Loaded then Object.Lazy_Load; end if; Result := Object.Object; end Prepare_Modify; -- ------------------------------ -- Check whether this object is initialized or not. -- ------------------------------ function Is_Null (Object : in Object_Ref'Class) return Boolean is begin return Object.Object = null; end Is_Null; -- ------------------------------ -- Check whether this object is saved in the database. -- Returns True if the object was saved in the database. -- ------------------------------ function Is_Inserted (Object : in Object_Ref'Class) return Boolean is begin if Object.Object = null then return False; else return Object.Object.Is_Created; end if; end Is_Inserted; -- ------------------------------ -- Check whether this object is loaded from the database. -- ------------------------------ function Is_Loaded (Object : in Object_Ref'Class) return Boolean is begin if Object.Object = null then return False; else return Object.Object.Is_Loaded and then Object.Object.Is_Created; end if; end Is_Loaded; -- ------------------------------ -- Check if at least one field is modified and the object must be saved. -- ------------------------------ function Is_Modified (Object : in Object_Ref'Class) return Boolean is begin if Object.Object = null then return False; else return Object.Object.Is_Modified; end if; end Is_Modified; -- ------------------------------ -- Load the object from the database if it was not already loaded. -- For a lazy association, the Object_Record is allocated and holds the primary key. -- The Is_Loaded boolean is cleared thus indicating the other values are not loaded. -- This procedure makes sure these values are loaded by invoking Load if necessary. -- Raises Session_Error if the session associated with the object is closed. -- ------------------------------ procedure Lazy_Load (Ref : in Object_Ref'Class) is begin if Ref.Object = null then raise NULL_ERROR; elsif not Ref.Object.Is_Loaded then if Ref.Object.Session = null then raise ADO.Sessions.Session_Error; end if; if Ref.Object.Session.Session = null then raise ADO.Sessions.Session_Error; end if; declare S : ADO.Sessions.Session := ADO.Sessions.Factory.Get_Session (Ref.Object.Session.Session.all'Access); begin Ref.Object.Load (S); end; end if; end Lazy_Load; -- ------------------------------ -- Internal method to get the object record instance and make sure it is fully loaded. -- If the object was not yet loaded, calls Lazy_Load to get the values from the -- database. Raises Session_Error if the session associated with the object is closed. -- ------------------------------ function Get_Load_Object (Ref : in Object_Ref'Class) return Object_Record_Access is begin Ref.Lazy_Load; return Ref.Object; end Get_Load_Object; -- ------------------------------ -- Internal method to get the object record instance. -- ------------------------------ function Get_Object (Ref : in Object_Ref'Class) return Object_Record_Access is begin return Ref.Object; end Get_Object; -- ------------------------------ -- Get the object key -- ------------------------------ function Get_Key (Ref : in Object_Ref'Class) return Object_Key is begin return Ref.Object.Key; end Get_Key; -- ------------------------------ -- Set the object key. -- ------------------------------ procedure Set_Key_Value (Ref : in out Object_Ref'Class; Value : in Identifier; Session : in ADO.Sessions.Session'Class) is begin if Ref.Object = null then Ref.Allocate; end if; Ref.Object.Is_Created := True; Ref.Object.Set_Key_Value (Value); Ref.Object.Session := Session.Get_Session_Proxy; Util.Concurrent.Counters.Increment (Ref.Object.Session.Counter); end Set_Key_Value; -- ------------------------------ -- Set the object key. -- ------------------------------ procedure Set_Key_Value (Ref : in out Object_Ref'Class; Value : in Ada.Strings.Unbounded.Unbounded_String; Session : in ADO.Sessions.Session'Class) is begin if Ref.Object = null then Ref.Allocate; end if; Ref.Object.Is_Created := True; Ref.Object.Set_Key_Value (Value); Ref.Object.Session := Session.Get_Session_Proxy; Util.Concurrent.Counters.Increment (Ref.Object.Session.Counter); end Set_Key_Value; -- ------------------------------ -- Check if the two objects are the same database objects. -- The comparison is only made on the primary key. -- Returns true if the two objects have the same primary key. -- ------------------------------ overriding function "=" (Left : Object_Ref; Right : Object_Ref) return Boolean is begin -- Same target object if Left.Object = Right.Object then return True; end if; -- One of the target object is null if Left.Object = null or else Right.Object = null then return False; end if; return Left.Object.Key = Right.Object.Key; end "="; procedure Set_Object (Ref : in out Object_Ref'Class; Object : in Object_Record_Access) is Is_Zero : Boolean; begin if Ref.Object /= null and then Ref.Object /= Object then Util.Concurrent.Counters.Decrement (Ref.Object.Counter, Is_Zero); if Is_Zero then Destroy (Ref.Object); end if; end if; Ref.Object := Object; end Set_Object; procedure Set_Object (Ref : in out Object_Ref'Class; Object : in Object_Record_Access; Session : in ADO.Sessions.Session'Class) is begin if Object /= null and then Object.Session = null then Object.Session := Session.Get_Session_Proxy; Util.Concurrent.Counters.Increment (Object.Session.Counter); end if; Ref.Set_Object (Object); end Set_Object; -- ------------------------------ -- Get the object primary key in a bean object. -- ------------------------------ function To_Object (Object : in Object_Ref'Class) return Util.Beans.Objects.Object is begin if Object.Object = null then return Util.Beans.Objects.Null_Object; else return To_Object (Object.Object.Get_Key); end if; end To_Object; -- ------------------------------ -- Get the object key -- ------------------------------ function Get_Key (Ref : in Object_Record'Class) return Object_Key is begin return Ref.Key; end Get_Key; -- ------------------------------ -- Set the object key -- ------------------------------ procedure Set_Key (Ref : in out Object_Record'Class; Key : in Object_Key) is begin Ref.Key := Key; end Set_Key; -- ------------------------------ -- Get the object key value as an identifier -- ------------------------------ function Get_Key_Value (Ref : in Object_Record'Class) return Identifier is begin return Ref.Key.Id; end Get_Key_Value; function Get_Key_Value (Ref : in Object_Record'Class) return Ada.Strings.Unbounded.Unbounded_String is begin return Ref.Key.Str; end Get_Key_Value; procedure Set_Key_Value (Ref : in out Object_Record'Class; Value : in Identifier) is begin Set_Value (Ref.Key, Value); end Set_Key_Value; procedure Set_Key_Value (Ref : in out Object_Record'Class; Value : in Ada.Strings.Unbounded.Unbounded_String) is begin Ref.Key.Str := Value; end Set_Key_Value; procedure Set_Key_Value (Ref : in out Object_Record'Class; Value : in String) is begin Ref.Key.Str := Ada.Strings.Unbounded.To_Unbounded_String (Value); end Set_Key_Value; -- ------------------------------ -- Get the table name associated with the object record. -- ------------------------------ function Get_Table_Name (Ref : in Object_Record'Class) return Util.Strings.Name_Access is begin if Ref.Key.Of_Class = null then return null; else return Ref.Key.Of_Class.Table; end if; end Get_Table_Name; -- ------------------------------ -- Check if this is a new object. -- Returns True if an insert is necessary to persist this object. -- ------------------------------ function Is_Created (Ref : in Object_Record'Class) return Boolean is begin return Ref.Is_Created; end Is_Created; -- ------------------------------ -- Mark the object as created in the database. -- ------------------------------ procedure Set_Created (Ref : in out Object_Record'Class) is begin Ref.Is_Created := True; Ref.Is_Loaded := True; Ref.Modified := (others => False); end Set_Created; -- ------------------------------ -- Check if at least one field is modified and the object must be saved. -- ------------------------------ function Is_Modified (Ref : in Object_Record'Class) return Boolean is begin return (for some Modified_Field of Ref.Modified => Modified_Field); end Is_Modified; -- ------------------------------ -- Check if the field at position Field was modified. -- ------------------------------ function Is_Modified (Ref : in Object_Record'Class; Field : in Column_Index) return Boolean is begin return Ref.Modified (Field); end Is_Modified; -- ------------------------------ -- Clear the modification flag associated with the field at -- position Field. -- ------------------------------ procedure Clear_Modified (Ref : in out Object_Record'Class; Field : in Column_Index) is begin Ref.Modified (Field) := False; end Clear_Modified; -- ------------------------------ -- Release the session proxy, deleting the instance if it is no longer used. -- The Detach parameter controls whether the session proxy must be detached -- from the database session. When set, the session proxy is no longer linked to the -- database session and trying to load the lazy object will raise the Session_Error -- exception. -- ------------------------------ procedure Release_Proxy (Proxy : in out Session_Proxy_Access; Detach : in Boolean := False) is procedure Free is new Ada.Unchecked_Deallocation (Object => Session_Proxy, Name => Session_Proxy_Access); Is_Zero : Boolean; begin if Proxy /= null then Util.Concurrent.Counters.Decrement (Proxy.Counter, Is_Zero); if Detach then Proxy.Session := null; end if; if Is_Zero then Free (Proxy); end if; Proxy := null; end if; end Release_Proxy; -- ------------------------------ -- Release the object. -- ------------------------------ overriding procedure Finalize (Object : in out Object_Record) is begin Release_Proxy (Object.Session); end Finalize; -- ------------------------------ -- Copy the source object record into the target. -- ------------------------------ procedure Copy (To : in out Object_Record; From : in Object_Record'Class) is begin To.Session := From.Session; To.Is_Created := From.Is_Created; To.Is_Loaded := From.Is_Loaded; To.Modified := From.Modified; To.Key := From.Key; end Copy; function Create_Session_Proxy (S : access ADO.Sessions.Session_Record) return Session_Proxy_Access is Result : constant Session_Proxy_Access := new Session_Proxy; begin Result.Session := S; return Result; end Create_Session_Proxy; -- ------------------------------ -- Set the object field to the new value in Into. If the new value is identical, -- the operation does nothing. Otherwise, the new value Value is copied -- to Into and the field identified by Field is marked as modified on -- the object. -- ------------------------------ procedure Set_Field_Unbounded_String (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Ada.Strings.Unbounded.Unbounded_String; Value : in Ada.Strings.Unbounded.Unbounded_String) is use Ada.Strings.Unbounded; begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Unbounded_String; procedure Set_Field_String (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Ada.Strings.Unbounded.Unbounded_String; Value : in String) is use Ada.Strings.Unbounded; begin if Into /= Value then Ada.Strings.Unbounded.Set_Unbounded_String (Into, Value); Object.Modified (Field) := True; end if; end Set_Field_String; procedure Set_Field_String (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Nullable_String; Value : in String) is use Ada.Strings.Unbounded; begin if Into.Is_Null or else Into.Value /= Value then Into.Is_Null := False; Ada.Strings.Unbounded.Set_Unbounded_String (Into.Value, Value); Object.Modified (Field) := True; end if; end Set_Field_String; procedure Set_Field_String (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Nullable_String; Value : in ADO.Nullable_String) is use Ada.Strings.Unbounded; begin if Into.Is_Null then if not Value.Is_Null then Into := Value; Object.Modified (Field) := True; end if; elsif Value.Is_Null then Into.Is_Null := True; Object.Modified (Field) := True; elsif Into.Value /= Value.Value then Into.Value := Value.Value; Object.Modified (Field) := True; end if; end Set_Field_String; procedure Set_Field_Time (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Ada.Calendar.Time; Value : in Ada.Calendar.Time) is use Ada.Calendar; begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Time; procedure Set_Field_Time (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Nullable_Time; Value : in ADO.Nullable_Time) is use Ada.Calendar; begin if Into.Is_Null then if not Value.Is_Null then Into := Value; Object.Modified (Field) := True; end if; elsif Value.Is_Null then Into.Is_Null := True; Object.Modified (Field) := True; elsif Into.Value /= Value.Value then Into.Value := Value.Value; Object.Modified (Field) := True; end if; end Set_Field_Time; procedure Set_Field_Integer (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Integer; Value : in Integer) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Integer; procedure Set_Field_Integer (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Nullable_Integer; Value : in ADO.Nullable_Integer) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Integer; procedure Set_Field_Natural (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Natural; Value : in Natural) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Natural; procedure Set_Field_Positive (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Positive; Value : in Positive) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Positive; procedure Set_Field_Boolean (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Boolean; Value : in Boolean) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Boolean; procedure Set_Field_Boolean (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Nullable_Boolean; Value : in Nullable_Boolean) is begin if Into.Is_Null then if not Value.Is_Null then Into := Value; Object.Modified (Field) := True; end if; elsif Value.Is_Null then Into.Is_Null := True; Object.Modified (Field) := True; elsif Into.Value /= Value.Value then Into.Value := Value.Value; Object.Modified (Field) := True; end if; end Set_Field_Boolean; procedure Set_Field_Float (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Float; Value : in Float) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Float; procedure Set_Field_Long_Float (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Long_Float; Value : in Long_Float) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Long_Float; procedure Set_Field_Object (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out Object_Ref'Class; Value : in Object_Ref'Class) is begin if Into.Object /= Value.Object then Set_Object (Into, Value.Object); if Into.Object /= null then Util.Concurrent.Counters.Increment (Into.Object.Counter); end if; Object.Modified (Field) := True; end if; end Set_Field_Object; procedure Set_Field_Identifier (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Identifier; Value : in ADO.Identifier) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Identifier; procedure Set_Field_Entity_Type (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Entity_Type; Value : in ADO.Entity_Type) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Entity_Type; procedure Set_Field_Entity_Type (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Nullable_Entity_Type; Value : in ADO.Nullable_Entity_Type) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Entity_Type; procedure Set_Field_Blob (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out ADO.Blob_Ref; Value : in ADO.Blob_Ref) is use type ADO.Blob_Ref; begin if Value /= Into then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Blob; procedure Set_Field_Key_Value (Object : in out Object_Record'Class; Field : in Column_Index; Value : in ADO.Identifier) is begin if Object.Get_Key_Value /= Value then Set_Key_Value (Object, Value); Object.Modified (Field) := True; end if; end Set_Field_Key_Value; procedure Set_Field_Key_Value (Object : in out Object_Record'Class; Field : in Column_Index; Value : in String) is use Ada.Strings.Unbounded; begin if Object.Key.Str /= Value then Set_Key_Value (Object, Value); Object.Modified (Field) := True; end if; end Set_Field_Key_Value; procedure Set_Field_Key_Value (Object : in out Object_Record'Class; Field : in Column_Index; Value : in Ada.Strings.Unbounded.Unbounded_String) is use Ada.Strings.Unbounded; begin if Object.Key.Str /= Value then Set_Key_Value (Object, Value); Object.Modified (Field) := True; end if; end Set_Field_Key_Value; procedure Set_Field_Operation (Object : in out Object_Record'Class; Field : in Column_Index; Into : in out T; Value : in T) is begin if Into /= Value then Into := Value; Object.Modified (Field) := True; end if; end Set_Field_Operation; -- ------------------------------ -- Mark the field identified by Field as modified. -- ------------------------------ procedure Set_Field (Object : in out Object_Record'Class; Field : in Column_Index) is begin Object.Modified (Field) := True; end Set_Field; end ADO.Objects;