-----------------------------------------------------------------------
--  asf.sessions -- ASF Sessions
--  Copyright (C) 2010, 2011 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.Unchecked_Deallocation;

--  The <b>ASF.Sessions</b> package is an Ada implementation of the
--  Java servlet Specification (See JSR 315 at jcp.org).
package body ASF.Sessions is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Returns true if the session is valid.
   --  ------------------------------
   function Is_Valid (Sess : in Session'Class) return Boolean is
   begin
      return Sess.Impl /= null and then Sess.Impl.Is_Active;
   end Is_Valid;

   --  ------------------------------
   --  Returns a string containing the unique identifier assigned to this session.
   --  The identifier is assigned by the servlet container and is implementation dependent.
   --  ------------------------------
   function Get_Id (Sess : in Session) return String is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Id.all;
      end if;
   end Get_Id;

   --  ------------------------------
   --  Returns the last time the client sent a request associated with this session,
   --  as the number of milliseconds since midnight January 1, 1970 GMT, and marked
   --  by the time the container recieved the request.
   --
   --  Actions that your application takes, such as getting or setting a value associated
   --  with the session, do not affect the access time.
   --  ------------------------------
   function Get_Last_Accessed_Time (Sess : in Session) return Ada.Calendar.Time is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Access_Time;
      end if;
   end Get_Last_Accessed_Time;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Sess : in Session) return Duration is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Max_Inactive;
      end if;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Sess     : in Session;
                                        Interval : in Duration) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         Sess.Impl.Max_Inactive := Interval;
      end if;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Returns the object bound with the specified name in this session,
   --  or null if no object is bound under the name.
   --  ------------------------------
   function Get_Attribute (Sess : in Session;
                           Name : in String) return EL.Objects.Object is
      Key : constant Unbounded_String := To_Unbounded_String (Name);
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      Sess.Impl.Lock.Read;
      declare
         Pos : constant EL.Objects.Maps.Cursor := Sess.Impl.Attributes.Find (Key);
      begin
         if EL.Objects.Maps.Has_Element (Pos) then
            return Value : constant EL.Objects.Object := EL.Objects.Maps.Element (Pos) do
               Sess.Impl.Lock.Release_Read;
            end return;
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Read;
            raise;
      end;
      Sess.Impl.Lock.Release_Read;
      return EL.Objects.Null_Object;
   end Get_Attribute;

   --  ------------------------------
   --  Binds an object to this session, using the name specified.
   --  If an object of the same name is already bound to the session,
   --  the object is replaced.
   --
   --  If the value passed in is null, this has the same effect as calling
   --  removeAttribute().
   --  ------------------------------
   procedure Set_Attribute (Sess  : in out Session;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      declare
         Key : constant Unbounded_String := To_Unbounded_String (Name);
      begin
         Sess.Impl.Lock.Write;
         if EL.Objects.Is_Null (Value) then
            Sess.Impl.Attributes.Delete (Key);
         else
            Sess.Impl.Attributes.Include (Key, Value);
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Write;
            raise;
      end;
      Sess.Impl.Lock.Release_Write;
   end Set_Attribute;

   --  ------------------------------
   --  Removes the object bound with the specified name from this session.
   --  If the session does not have an object bound with the specified name,
   --  this method does nothing.
   --  ------------------------------
   procedure Remove_Attribute (Sess : in out Session;
                               Name : in String) is
   begin
      Set_Attribute (Sess, Name, EL.Objects.Null_Object);
   end Remove_Attribute;

   --  ------------------------------
   --  Gets the principal that authenticated to the session.
   --  Returns null if there is no principal authenticated.
   --  ------------------------------
   function Get_Principal (Sess : in Session) return ASF.Principals.Principal_Access is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      return Sess.Impl.Principal;
   end Get_Principal;

   --  ------------------------------
   --  Sets the principal associated with the session.
   --  ------------------------------
   procedure Set_Principal (Sess      : in out Session;
                            Principal : in ASF.Principals.Principal_Access) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      Sess.Impl.Principal := Principal;
   end Set_Principal;

   --  ------------------------------
   --  Invalidates this session then unbinds any objects bound to it.
   --  ------------------------------
   procedure Invalidate (Sess : in out Session) is
   begin
      if Sess.Impl /= null then
         Sess.Impl.Is_Active := False;
         Finalize (Sess);
      end if;
   end Invalidate;

   --  ------------------------------
   --  Adjust (increment) the session record reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Ref_Counter);
      end if;
   end Adjust;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Session_Record'Class,
                                     Name   => Session_Record_Access);

   --  ------------------------------
   --  Decrement the session record reference counter and free the session record
   --  if this was the last session reference.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Session) is
      Release : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Ref_Counter, Release);
         if Release then
            Free (Object.Impl);
         else
            Object.Impl := null;
         end if;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out Session_Record) is
   begin
      Free (Object.Id);
   end Finalize;

end ASF.Sessions;

-----------------------------------------------------------------------
--  asf.sessions -- ASF Sessions
--  Copyright (C) 2010, 2011 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.Unchecked_Deallocation;

--  The <b>ASF.Sessions</b> package is an Ada implementation of the
--  Java servlet Specification (See JSR 315 at jcp.org).
package body ASF.Sessions is

   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Returns true if the session is valid.
   --  ------------------------------
   function Is_Valid (Sess : in Session'Class) return Boolean is
   begin
      return Sess.Impl /= null and then Sess.Impl.Is_Active;
   end Is_Valid;

   --  ------------------------------
   --  Returns a string containing the unique identifier assigned to this session.
   --  The identifier is assigned by the servlet container and is implementation dependent.
   --  ------------------------------
   function Get_Id (Sess : in Session) return String is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Id.all;
      end if;
   end Get_Id;

   --  ------------------------------
   --  Returns the last time the client sent a request associated with this session,
   --  as the number of milliseconds since midnight January 1, 1970 GMT, and marked
   --  by the time the container recieved the request.
   --
   --  Actions that your application takes, such as getting or setting a value associated
   --  with the session, do not affect the access time.
   --  ------------------------------
   function Get_Last_Accessed_Time (Sess : in Session) return Ada.Calendar.Time is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Access_Time;
      end if;
   end Get_Last_Accessed_Time;

   --  ------------------------------
   --  Returns the maximum time interval, in seconds, that the servlet container will
   --  keep this session open between client accesses. After this interval, the servlet
   --  container will invalidate the session. The maximum time interval can be set with
   --  the Set_Max_Inactive_Interval method.
   --  A negative time indicates the session should never timeout.
   --  ------------------------------
   function Get_Max_Inactive_Interval (Sess : in Session) return Duration is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         return Sess.Impl.Max_Inactive;
      end if;
   end Get_Max_Inactive_Interval;

   --  ------------------------------
   --  Specifies the time, in seconds, between client requests before the servlet
   --  container will invalidate this session. A negative time indicates the session
   --  should never timeout.
   --  ------------------------------
   procedure Set_Max_Inactive_Interval (Sess     : in Session;
                                        Interval : in Duration) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      else
         Sess.Impl.Max_Inactive := Interval;
      end if;
   end Set_Max_Inactive_Interval;

   --  ------------------------------
   --  Returns the object bound with the specified name in this session,
   --  or null if no object is bound under the name.
   --  ------------------------------
   function Get_Attribute (Sess : in Session;
                           Name : in String) return EL.Objects.Object is
      Key : constant Unbounded_String := To_Unbounded_String (Name);
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      Sess.Impl.Lock.Read;
      declare
         Pos : constant EL.Objects.Maps.Cursor := Sess.Impl.Attributes.Find (Key);
      begin
         if EL.Objects.Maps.Has_Element (Pos) then
            return Value : constant EL.Objects.Object := EL.Objects.Maps.Element (Pos) do
               Sess.Impl.Lock.Release_Read;
            end return;
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Read;
            raise;
      end;
      Sess.Impl.Lock.Release_Read;
      return EL.Objects.Null_Object;
   end Get_Attribute;

   --  ------------------------------
   --  Binds an object to this session, using the name specified.
   --  If an object of the same name is already bound to the session,
   --  the object is replaced.
   --
   --  If the value passed in is null, this has the same effect as calling
   --  removeAttribute().
   --  ------------------------------
   procedure Set_Attribute (Sess  : in out Session;
                            Name  : in String;
                            Value : in EL.Objects.Object) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;

      declare
         Key : constant Unbounded_String := To_Unbounded_String (Name);
      begin
         Sess.Impl.Lock.Write;
         if EL.Objects.Is_Null (Value) then
            Sess.Impl.Attributes.Delete (Key);
         else
            Sess.Impl.Attributes.Include (Key, Value);
         end if;

      exception
         when others =>
            Sess.Impl.Lock.Release_Write;
            raise;
      end;
      Sess.Impl.Lock.Release_Write;
   end Set_Attribute;

   --  ------------------------------
   --  Removes the object bound with the specified name from this session.
   --  If the session does not have an object bound with the specified name,
   --  this method does nothing.
   --  ------------------------------
   procedure Remove_Attribute (Sess : in out Session;
                               Name : in String) is
   begin
      Set_Attribute (Sess, Name, EL.Objects.Null_Object);
   end Remove_Attribute;

   --  ------------------------------
   --  Gets the principal that authenticated to the session.
   --  Returns null if there is no principal authenticated.
   --  ------------------------------
   function Get_Principal (Sess : in Session) return ASF.Principals.Principal_Access is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      return Sess.Impl.Principal;
   end Get_Principal;

   --  ------------------------------
   --  Sets the principal associated with the session.
   --  ------------------------------
   procedure Set_Principal (Sess      : in out Session;
                            Principal : in ASF.Principals.Principal_Access) is
   begin
      if Sess.Impl = null or else not Sess.Impl.Is_Active then
         raise No_Session;
      end if;
      Sess.Impl.Principal := Principal;
   end Set_Principal;

   --  ------------------------------
   --  Invalidates this session then unbinds any objects bound to it.
   --  ------------------------------
   procedure Invalidate (Sess : in out Session) is
   begin
      if Sess.Impl /= null then
         Sess.Impl.Is_Active := False;
         Finalize (Sess);
      end if;
   end Invalidate;

   --  ------------------------------
   --  Adjust (increment) the session record reference counter.
   --  ------------------------------
   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Ref_Counter);
      end if;
   end Adjust;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Session_Record'Class,
                                     Name   => Session_Record_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => ASF.Principals.Principal'Class,
                                     Name   => ASF.Principals.Principal_Access);

   --  ------------------------------
   --  Decrement the session record reference counter and free the session record
   --  if this was the last session reference.
   --  ------------------------------
   overriding
   procedure Finalize (Object : in out Session) is
      Release : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Ref_Counter, Release);
         if Release then
            Free (Object.Impl.Principal);
            Free (Object.Impl);
         else
            Object.Impl := null;
         end if;
      end if;
   end Finalize;

   overriding
   procedure Finalize (Object : in out Session_Record) is
   begin
      Free (Object.Id);
   end Finalize;

end ASF.Sessions;

Delete the principal object when the session is deleted.


-----------------------------------------------------------------------
--  gen-model -- Model for Code Generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2018 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.Fixed;
with Ada.Strings.Maps;
with DOM.Core.Nodes;
with Gen.Utils;
package body Gen.Model is

   Trim_Chars : constant Ada.Strings.Maps.Character_Set
     := Ada.Strings.Maps.To_Set (" " & ASCII.HT & ASCII.LF & ASCII.CR);

   --  ------------------------------
   --  Get the object unique name.
   --  ------------------------------
   function Get_Name (From : in Definition) return String is
   begin
      return Ada.Strings.Unbounded.To_String (From.Def_Name);
   end Get_Name;

   function Name (From : in Definition) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return From.Def_Name;
   end Name;

   --  ------------------------------
   --  Set the object unique name.
   --  ------------------------------
   procedure Set_Name (Def  : in out Definition;
                       Name : in String) is
   begin
      Def.Def_Name := Ada.Strings.Unbounded.To_Unbounded_String (Name);
   end Set_Name;

   procedure Set_Name (Def  : in out Definition;
                       Name : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Def.Def_Name := Name;
   end Set_Name;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "comment" then
         return From.Comment;

      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Row_Index);

      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Def_Name);
      else
         return From.Attrs.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Attribute (From : in Definition;
                           Name : in String) return String is
      V : constant Util.Beans.Objects.Object := From.Get_Value (Name);
   begin
      return Util.Beans.Objects.To_String (V);
   end Get_Attribute;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Attribute (From : in Definition;
                           Name : in String) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (From.Get_Attribute (Name));
   end Get_Attribute;

   --  ------------------------------
   --  Set the comment associated with the element.
   --  ------------------------------
   procedure Set_Comment (Def     : in out Definition;
                          Comment : in String) is
      Trimmed_Comment : constant String := Ada.Strings.Fixed.Trim (Comment, Trim_Chars, Trim_Chars);
   begin
      Def.Comment := Util.Beans.Objects.To_Object (Trimmed_Comment);
   end Set_Comment;

   --  ------------------------------
   --  Get the comment associated with the element.
   --  ------------------------------
   function Get_Comment (Def : in Definition) return Util.Beans.Objects.Object is
   begin
      return Def.Comment;
   end Get_Comment;

   --  ------------------------------
   --  Set the location (file and line) where the model element is defined in the XMI file.
   --  ------------------------------
   procedure Set_Location (Node     : in out Definition;
                           Location : in String) is
   begin
      Node.Location := Ada.Strings.Unbounded.To_Unbounded_String (Location);
   end Set_Location;

   --  ------------------------------
   --  Get the location file and line where the model element is defined.
   --  ------------------------------
   function Get_Location (Node : in Definition) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Node.Location);
   end Get_Location;

   --  ------------------------------
   --  Initialize the definition from the DOM node attributes.
   --  ------------------------------
   procedure Initialize (Def  : in out Definition;
                         Name : in Ada.Strings.Unbounded.Unbounded_String;
                         Node : in DOM.Core.Node) is
      use type DOM.Core.Node;

      Attrs : constant DOM.Core.Named_Node_Map := DOM.Core.Nodes.Attributes (Node);
   begin
      Def.Def_Name := Name;
      Def.Comment := Util.Beans.Objects.To_Object (Gen.Utils.Get_Comment (Node));

      for I in 0 .. DOM.Core.Nodes.Length (Attrs) loop
         declare
            A : constant DOM.Core.Node := DOM.Core.Nodes.Item (Attrs, I);
         begin
            if A /= null then
               declare
                  Name  : constant DOM.Core.DOM_String := DOM.Core.Nodes.Node_Name (A);
                  Value : constant DOM.Core.DOM_String := DOM.Core.Nodes.Node_Value (A);
               begin
                  Def.Attrs.Include (Name, Util.Beans.Objects.To_Object (Value));
               end;
            end if;
         end;
      end loop;
   end Initialize;

end Gen.Model;

-----------------------------------------------------------------------
--  gen-model -- Model for Code Generator
--  Copyright (C) 2009, 2010, 2011, 2012, 2018 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.Fixed;
with Ada.Strings.Maps;
with DOM.Core.Nodes;
with Gen.Utils;
package body Gen.Model is

   Trim_Chars : constant Ada.Strings.Maps.Character_Set
     := Ada.Strings.Maps.To_Set (" " & ASCII.HT & ASCII.LF & ASCII.CR);

   --  ------------------------------
   --  Get the object unique name.
   --  ------------------------------
   function Get_Name (From : in Definition) return String is
   begin
      return Ada.Strings.Unbounded.To_String (From.Def_Name);
   end Get_Name;

   function Name (From : in Definition) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return From.Def_Name;
   end Name;

   --  ------------------------------
   --  Set the object unique name.
   --  ------------------------------
   procedure Set_Name (Def  : in out Definition;
                       Name : in String) is
   begin
      Def.Def_Name := Ada.Strings.Unbounded.To_Unbounded_String (Name);
   end Set_Name;

   procedure Set_Name (Def  : in out Definition;
                       Name : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Def.Def_Name := Name;
   end Set_Name;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : in Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "comment" then
         return From.Comment;

      elsif Name = "rowIndex" then
         return Util.Beans.Objects.To_Object (From.Row_Index);

      elsif Name = "name" then
         return Util.Beans.Objects.To_Object (From.Def_Name);
      else
         return From.Attrs.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Attribute (From : in Definition;
                           Name : in String) return String is
      V : constant Util.Beans.Objects.Object := From.Get_Value (Name);
   begin
      return Util.Beans.Objects.To_String (V);
   end Get_Attribute;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Attribute (From : in Definition;
                           Name : in String) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (From.Get_Attribute (Name));
   end Get_Attribute;

   --  ------------------------------
   --  Set the comment associated with the element.
   --  ------------------------------
   procedure Set_Comment (Def     : in out Definition;
                          Comment : in String) is
      Trimmed_Comment : constant String := Ada.Strings.Fixed.Trim (Comment, Trim_Chars, Trim_Chars);
   begin
      Def.Comment := Util.Beans.Objects.To_Object (Trimmed_Comment);
   end Set_Comment;

   --  ------------------------------
   --  Get the comment associated with the element.
   --  ------------------------------
   function Get_Comment (Def : in Definition) return Util.Beans.Objects.Object is
   begin
      return Def.Comment;
   end Get_Comment;

   --  ------------------------------
   --  Set the location (file and line) where the model element is defined in the XMI file.
   --  ------------------------------
   procedure Set_Location (Node     : in out Definition;
                           Location : in String) is
   begin
      Node.Location := Ada.Strings.Unbounded.To_Unbounded_String (Location);
   end Set_Location;

   --  ------------------------------
   --  Get the location file and line where the model element is defined.
   --  ------------------------------
   function Get_Location (Node : in Definition) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Node.Location);
   end Get_Location;

   --  ------------------------------
   --  Initialize the definition from the DOM node attributes.
   --  ------------------------------
   procedure Initialize (Def  : in out Definition;
                         Name : in Ada.Strings.Unbounded.Unbounded_String;
                         Node : in DOM.Core.Node) is
      use type DOM.Core.Node;

      Attrs : constant DOM.Core.Named_Node_Map := DOM.Core.Nodes.Attributes (Node);
   begin
      Def.Def_Name := Name;
      Def.Comment := Util.Beans.Objects.To_Object (Gen.Utils.Get_Comment (Node));

      for I in 0 .. DOM.Core.Nodes.Length (Attrs) loop
         declare
            A : constant DOM.Core.Node := DOM.Core.Nodes.Item (Attrs, I);
         begin
            if A /= null then
               declare
                  Name  : constant DOM.Core.DOM_String := DOM.Core.Nodes.Node_Name (A);
                  Value : constant DOM.Core.DOM_String := DOM.Core.Nodes.Node_Value (A);
               begin
                  Def.Attrs.Include (Name, Util.Beans.Objects.To_Object (Value));
               end;
            end if;
         end;
      end loop;
   end Initialize;

   --  ------------------------------
   --  Validate the definition by checking and reporting problems to the logger interface.
   --  ------------------------------
   procedure Validate (Def : in out Definition;
                       Log : in out Util.Log.Logging'Class) is
   begin
      if Ada.Strings.Unbounded.Length (Def.Def_Name) = 0 then
         Log.Error (Def.Get_Location & ": name is empty");
      end if;
   end Validate;

end Gen.Model;

Implement the Validate procedure

Implement the Validate procedure


-----------------------------------------------------------------------
--  mat-readers-sockets -- Reader for TCP/IP sockets
--  Copyright (C) 2014 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.Streams;
with Util.Log.Loggers;

package body MAT.Readers.Streams.Sockets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Sockets");

   BUFFER_SIZE  : constant Natural := 100 * 1024;

   --  ------------------------------
   --  Initialize the socket listener.
   --  ------------------------------
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type) is
   begin
      GNAT.Sockets.Create_Selector (Listener.Accept_Selector);
   end Initialize;

   --  ------------------------------
   --  Destroy the socket listener.
   --  ------------------------------
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type) is
      use type GNAT.Sockets.Selector_Type;
   begin
      GNAT.Sockets.Close_Selector (Listener.Accept_Selector);
   end Finalize;

   --  ------------------------------
   --  Open the socket to accept connections and start the listener task.
   --  ------------------------------
   procedure Start (Listener : in out Socket_Listener_Type;
                    List     : in MAT.Readers.Reader_List_Type_Access;
                    Address  : in GNAT.Sockets.Sock_Addr_Type) is
   begin
      Log.Info ("Starting the listener socket task");

      Listener.List := List;
      Listener.Listener.Start (Listener'Unchecked_Access, Address);
   end Start;

   --  ------------------------------
   --  Stop the listener socket.
   --  ------------------------------
   procedure Stop (Listener : in out Socket_Listener_Type) is
   begin
      GNAT.Sockets.Abort_Selector (Listener.Accept_Selector);
   end Stop;

   --  ------------------------------
   --  Create a target instance for the new client.
   --  ------------------------------
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type) is
      Reader : constant Socket_Reader_Type_Access := new Socket_Reader_Type;
   begin
      Reader.Client := Client;
      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Reader.Socket'Unchecked_Access,
                                Output => null);
      Reader.Server.Start (Reader, Client);
      Listener.List.Initialize (Reader.all);
      Listener.Clients.Append (Reader);
   end Create_Target;

   task body Socket_Listener_Task is
      use type GNAT.Sockets.Socket_Type;
      use type GNAT.Sockets.Selector_Status;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Listener_Type_Access;
      Client   : GNAT.Sockets.Socket_Type;
      Selector_Status : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (Listener : in Socket_Listener_Type_Access;
                       Address  : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := Listener;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      loop
         GNAT.Sockets.Accept_Socket (Server   => Server,
                                     Socket   => Client,
                                     Address  => Peer,
                                     Timeout  => GNAT.Sockets.Forever,
                                     Selector => Instance.Accept_Selector'Access,
                                     Status   => Selector_Status);
         exit when Selector_Status = GNAT.Sockets.Aborted;
         if Selector_Status = GNAT.Sockets.Completed then
            Instance.Create_Target (Client  => Client,
                                    Address => Peer);
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);
      declare
         Iter : Socket_Client_Lists.Cursor := Instance.Clients.First;
      begin
         while Socket_Client_Lists.Has_Element (Iter) loop
            GNAT.Sockets.Close_Socket (Socket_Client_Lists.Element (Iter).Client);
            Iter := Socket_Client_Lists.Next (Iter);
         end loop;
      end;
   end Socket_Listener_Task;

   task body Socket_Reader_Task is
      use type GNAT.Sockets.Socket_Type;

      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
   begin
      select
         accept Start (Reader  : in Socket_Reader_Type_Access;
                       Client  : in GNAT.Sockets.Socket_Type) do
            Instance := Reader;
            Socket := Client;
         end Start;
      or
         terminate;
      end select;
      Instance.Socket.Open (Socket);
      Instance.Read_All;
      GNAT.Sockets.Close_Socket (Socket);

   exception
      when E : others =>
         Log.Error ("Exception", E, True);
         GNAT.Sockets.Close_Socket (Socket);

   end Socket_Reader_Task;

   procedure Close (Reader : in out Socket_Reader_Type) is
   begin
      Reader.Stop := True;
   end Close;

end MAT.Readers.Streams.Sockets;

-----------------------------------------------------------------------
--  mat-readers-sockets -- Reader for TCP/IP sockets
--  Copyright (C) 2014 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 Util.Log.Loggers;

package body MAT.Readers.Streams.Sockets is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Readers.Sockets");

   BUFFER_SIZE  : constant Natural := 100 * 1024;

   --  ------------------------------
   --  Initialize the socket listener.
   --  ------------------------------
   overriding
   procedure Initialize (Listener : in out Socket_Listener_Type) is
   begin
      GNAT.Sockets.Create_Selector (Listener.Accept_Selector);
   end Initialize;

   --  ------------------------------
   --  Destroy the socket listener.
   --  ------------------------------
   overriding
   procedure Finalize (Listener : in out Socket_Listener_Type) is
      use type GNAT.Sockets.Selector_Type;
   begin
      GNAT.Sockets.Close_Selector (Listener.Accept_Selector);
   end Finalize;

   --  ------------------------------
   --  Open the socket to accept connections and start the listener task.
   --  ------------------------------
   procedure Start (Listener : in out Socket_Listener_Type;
                    List     : in MAT.Readers.Reader_List_Type_Access;
                    Address  : in GNAT.Sockets.Sock_Addr_Type) is
   begin
      Log.Info ("Starting the listener socket task");

      Listener.List := List;
      Listener.Listener.Start (Listener'Unchecked_Access, Address);
   end Start;

   --  ------------------------------
   --  Stop the listener socket.
   --  ------------------------------
   procedure Stop (Listener : in out Socket_Listener_Type) is
   begin
      GNAT.Sockets.Abort_Selector (Listener.Accept_Selector);
   end Stop;

   --  ------------------------------
   --  Create a target instance for the new client.
   --  ------------------------------
   procedure Create_Target (Listener : in out Socket_Listener_Type;
                            Client   : in GNAT.Sockets.Socket_Type;
                            Address  : in GNAT.Sockets.Sock_Addr_Type) is
      Reader : constant Socket_Reader_Type_Access := new Socket_Reader_Type;
   begin
      Reader.Client := Client;
      Reader.Stream.Initialize (Size   => BUFFER_SIZE,
                                Input  => Reader.Socket'Unchecked_Access,
                                Output => null);
      Reader.Server.Start (Reader, Client);
      Listener.List.Initialize (Reader.all);
      Listener.Clients.Append (Reader);
   end Create_Target;

   task body Socket_Listener_Task is
      use type GNAT.Sockets.Socket_Type;
      use type GNAT.Sockets.Selector_Status;

      Peer     : GNAT.Sockets.Sock_Addr_Type;
      Server   : GNAT.Sockets.Socket_Type;
      Instance : Socket_Listener_Type_Access;
      Client   : GNAT.Sockets.Socket_Type;
      Selector_Status : GNAT.Sockets.Selector_Status;
   begin
      select
         accept Start (Listener : in Socket_Listener_Type_Access;
                       Address  : in GNAT.Sockets.Sock_Addr_Type) do
            Instance := Listener;
            GNAT.Sockets.Create_Socket (Server);
            GNAT.Sockets.Set_Socket_Option (Server, GNAT.Sockets.Socket_Level,
                                            (GNAT.Sockets.Reuse_Address, True));
            GNAT.Sockets.Bind_Socket (Server, Address);
            GNAT.Sockets.Listen_Socket (Server);
         end Start;
      or
         terminate;
      end select;
      loop
         GNAT.Sockets.Accept_Socket (Server   => Server,
                                     Socket   => Client,
                                     Address  => Peer,
                                     Timeout  => GNAT.Sockets.Forever,
                                     Selector => Instance.Accept_Selector'Access,
                                     Status   => Selector_Status);
         exit when Selector_Status = GNAT.Sockets.Aborted;
         if Selector_Status = GNAT.Sockets.Completed then
            Instance.Create_Target (Client  => Client,
                                    Address => Peer);
         end if;
      end loop;
      GNAT.Sockets.Close_Socket (Server);
      declare
         Iter : Socket_Client_Lists.Cursor := Instance.Clients.First;
      begin
         while Socket_Client_Lists.Has_Element (Iter) loop
            GNAT.Sockets.Close_Socket (Socket_Client_Lists.Element (Iter).Client);
            Iter := Socket_Client_Lists.Next (Iter);
         end loop;
      end;
   end Socket_Listener_Task;

   task body Socket_Reader_Task is
      use type GNAT.Sockets.Socket_Type;

      Instance : Socket_Reader_Type_Access;
      Socket   : GNAT.Sockets.Socket_Type;
   begin
      select
         accept Start (Reader  : in Socket_Reader_Type_Access;
                       Client  : in GNAT.Sockets.Socket_Type) do
            Instance := Reader;
            Socket := Client;
         end Start;
      or
         terminate;
      end select;
      Instance.Socket.Open (Socket);
      Instance.Read_All;
      GNAT.Sockets.Close_Socket (Socket);

   exception
      when E : others =>
         Log.Error ("Exception", E, True);
         GNAT.Sockets.Close_Socket (Socket);

   end Socket_Reader_Task;

   procedure Close (Reader : in out Socket_Reader_Type) is
   begin
      Reader.Stop := True;
   end Close;

end MAT.Readers.Streams.Sockets;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2011, 2012, 2013, 2014 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 Util.Test_Caller;

with ADO;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Blogs.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Blogs.Modules.Tests is

   use Util.Tests;
   use ADO;

   package Caller is new Util.Test_Caller (Test, "Blogs.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Blogs.Services.Create_Blog",
                       Test_Create_Blog'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Services.Create_Post",
                       Test_Create_Post'Access);

   end Add_Tests;

   --  ------------------------------
   --  Test creation of a blog
   --  ------------------------------
   procedure Test_Create_Blog (T : in out Test) is
      Manager   : AWA.Blogs.Modules.Blog_Module_Access;
      Blog_Id   : ADO.Identifier;
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-blog@test.com");

      Manager := AWA.Blogs.Modules.Get_Blog_Module;
      Manager.Create_Blog (Workspace_Id => 0,
                           Title        => "My blog",
                           Result       => Blog_Id);
      T.Assert (Blog_Id > 0, "Invalid blog identifier");
   end Test_Create_Blog;

   --  ------------------------------
   --  Test creating and updating of a blog post
   --  ------------------------------
   procedure Test_Create_Post (T : in out Test) is
      Manager   : AWA.Blogs.Modules.Blog_Module_Access;
      Blog_Id   : ADO.Identifier;
      Post_Id   : ADO.Identifier;
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-blog-post@test.com");

      Manager := AWA.Blogs.Modules.Get_Blog_Module;
      Manager.Create_Blog (Workspace_Id => 0,
                           Title        => "My blog post",
                           Result       => Blog_Id);
      T.Assert (Blog_Id > 0, "Invalid blog identifier");

      for I in 1 .. 5 loop
         Manager.Create_Post (Blog_Id => Blog_Id,
                              Title   => "Testing blog title",
                              URI     => "testing-blog-title",
                              Text    => "The blog content",
                              Comment => False,
                              Status  => AWA.Blogs.Models.POST_DRAFT,
                              Result  => Post_Id);
         T.Assert (Post_Id > 0, "Invalid post identifier");

         Manager.Update_Post (Post_Id => Post_Id,
                              Title   => "New blog post title",
                              URI     => "testing-blog-title",
                              Text    => "The new post content",
                              Comment => True,
                              Status  => AWA.Blogs.Models.POST_DRAFT);

         --  Keep the last post in the database.
         exit when I = 5;

         Manager.Delete_Post (Post_Id => Post_Id);

         --  Verify that a Not_Found exception is raised if the post was deleted.
         begin
            Manager.Update_Post (Post_Id => Post_Id,
                                 Title   => "Something",
                                 Text    => "Content",
                                 URI     => "testing-blog-title",
                                 Comment => True,
                                 Status  => AWA.Blogs.Models.POST_DRAFT);
            T.Assert (False, "Exception Not_Found was not raised");
         exception
            when Not_Found =>
               null;
         end;

         --  Verify that a Not_Found exception is raised if the post was deleted.
         begin
            Manager.Delete_Post (Post_Id => Post_Id);
            T.Assert (False, "Exception Not_Found was not raised");
         exception
            when Not_Found =>
               null;
         end;
      end loop;

   end Test_Create_Post;

end AWA.Blogs.Modules.Tests;

-----------------------------------------------------------------------
--  awa-blogs-tests -- Unit tests for blogs module
--  Copyright (C) 2011, 2012, 2013, 2014, 2015 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 Util.Test_Caller;

with ADO;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Blogs.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Blogs.Modules.Tests is

   use Util.Tests;
   use ADO;

   package Caller is new Util.Test_Caller (Test, "Blogs.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Blogs.Services.Create_Blog",
                       Test_Create_Blog'Access);
      Caller.Add_Test (Suite, "Test AWA.Blogs.Services.Create_Post",
                       Test_Create_Post'Access);

   end Add_Tests;

   --  ------------------------------
   --  Test creation of a blog
   --  ------------------------------
   procedure Test_Create_Blog (T : in out Test) is
      Manager   : AWA.Blogs.Modules.Blog_Module_Access;
      Blog_Id   : ADO.Identifier;
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-blog@test.com");

      Manager := AWA.Blogs.Modules.Get_Blog_Module;
      Manager.Create_Blog (Title        => "My blog",
                           Result       => Blog_Id);
      T.Assert (Blog_Id > 0, "Invalid blog identifier");
   end Test_Create_Blog;

   --  ------------------------------
   --  Test creating and updating of a blog post
   --  ------------------------------
   procedure Test_Create_Post (T : in out Test) is
      Manager   : AWA.Blogs.Modules.Blog_Module_Access;
      Blog_Id   : ADO.Identifier;
      Post_Id   : ADO.Identifier;
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-blog-post@test.com");

      Manager := AWA.Blogs.Modules.Get_Blog_Module;
      Manager.Create_Blog (Title        => "My blog post",
                           Result       => Blog_Id);
      T.Assert (Blog_Id > 0, "Invalid blog identifier");

      for I in 1 .. 5 loop
         Manager.Create_Post (Blog_Id => Blog_Id,
                              Title   => "Testing blog title",
                              URI     => "testing-blog-title",
                              Text    => "The blog content",
                              Comment => False,
                              Status  => AWA.Blogs.Models.POST_DRAFT,
                              Result  => Post_Id);
         T.Assert (Post_Id > 0, "Invalid post identifier");

         Manager.Update_Post (Post_Id => Post_Id,
                              Title   => "New blog post title",
                              URI     => "testing-blog-title",
                              Text    => "The new post content",
                              Comment => True,
                              Status  => AWA.Blogs.Models.POST_DRAFT);

         --  Keep the last post in the database.
         exit when I = 5;

         Manager.Delete_Post (Post_Id => Post_Id);

         --  Verify that a Not_Found exception is raised if the post was deleted.
         begin
            Manager.Update_Post (Post_Id => Post_Id,
                                 Title   => "Something",
                                 Text    => "Content",
                                 URI     => "testing-blog-title",
                                 Comment => True,
                                 Status  => AWA.Blogs.Models.POST_DRAFT);
            T.Assert (False, "Exception Not_Found was not raised");
         exception
            when Not_Found =>
               null;
         end;

         --  Verify that a Not_Found exception is raised if the post was deleted.
         begin
            Manager.Delete_Post (Post_Id => Post_Id);
            T.Assert (False, "Exception Not_Found was not raised");
         exception
            when Not_Found =>
               null;
         end;
      end loop;

   end Test_Create_Post;

end AWA.Blogs.Modules.Tests;

Remove the Workspace_Id parameter for the Create_Blog procedure


-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016 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.Wide_Wide_Unbounded;
with Ada.Characters.Conversions;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_String (S : in WString; Substitute : in Character := ' ') return String
                       renames Ada.Characters.Conversions.To_String;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   function To_WString (S : in String) return WString
                        renames Ada.Characters.Conversions.To_Wide_Wide_String;

   procedure Append (Into : in out UString; S : in WString)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   procedure Append (Into : in out UString; S : in WChar)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   function Length (S : in UString) return Natural
                    renames Ada.Strings.Wide_Wide_Unbounded.Length;

   function Element (S : in UString; Pos : in Positive) return WChar
                     renames Ada.Strings.Wide_Wide_Unbounded.Element;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

end Wiki.Strings;

-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016 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.Wide_Wide_Unbounded;
with Ada.Characters.Conversions;
with Ada.Wide_Wide_Characters.Handling;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_String (S : in WString; Substitute : in Character := ' ') return String
                       renames Ada.Characters.Conversions.To_String;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   function To_WString (S : in String) return WString
                        renames Ada.Characters.Conversions.To_Wide_Wide_String;

   procedure Append (Into : in out UString; S : in WString)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   procedure Append (Into : in out UString; S : in WChar)
                     renames Ada.Strings.Wide_Wide_Unbounded.Append;

   function Length (S : in UString) return Natural
                    renames Ada.Strings.Wide_Wide_Unbounded.Length;

   function Element (S : in UString; Pos : in Positive) return WChar
                     renames Ada.Strings.Wide_Wide_Unbounded.Element;

   function Is_Alphanumeric (C : in WChar) return Boolean
     renames Ada.Wide_Wide_Characters.Handling.Is_Alphanumeric;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

end Wiki.Strings;

Declare the Is_Alphanumeric function

Declare the Is_Alphanumeric function


-----------------------------------------------------------------------
--  el -- Evaluate an EL expression
--  Copyright (C) 2009, 2010 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 EL.Expressions;
with EL.Objects;
with EL.Contexts.Default;
with Ada.Text_IO;

procedure Evaluate is

   Ctx    : EL.Contexts.Default.Default_Context;
   E      : EL.Expressions.Expression;
   Result : EL.Objects.Object;
begin
   E := EL.Expressions.Create_Expression ("#{1 + (2 - 3) * 4}", Ctx);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("Result: " & EL.Objects.To_String (Result));
end Evaluate;

-----------------------------------------------------------------------
--  el -- Evaluate an EL expression
--  Copyright (C) 2009, 2010, 2011 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 EL.Expressions;
with EL.Objects;
with EL.Contexts.Default;
with Ada.Text_IO;

procedure Evaluate is
   Expr   : constant String := "#{1 + (2 - 3) * 4}";
   Ctx    : EL.Contexts.Default.Default_Context;
   E      : EL.Expressions.Expression;
   Result : EL.Objects.Object;
begin
   Ada.Text_IO.Put_Line ("Evaluate: " & Expr);
   E := EL.Expressions.Create_Expression (Expr, Ctx);
   Result := E.Get_Value (Ctx);
   Ada.Text_IO.Put_Line ("Result: " & EL.Objects.To_String (Result));
end Evaluate;

Print the expression being evaluated

Print the expression being evaluated


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  Copyright (C) 2014 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 MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_THREAD);

   type Console_Type is abstract tagged limited private;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

private

   type Console_Type is abstract tagged limited record
      N : Natural;
   end record;

end MAT.Consoles;

-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  Copyright (C) 2014 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 MAT.Types;
package MAT.Consoles is

   type Field_Type is (F_ADDR,
                       F_SIZE,
                       F_THREAD);

   type Console_Type is abstract tagged limited private;

   --  Print the field value for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String) is abstract;

   --  Print the title for the given field.
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is abstract;

   --  Format the address and print it for the given field.
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr);

   --  Format the size and print it for the given field.
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size);

private

   type Console_Type is abstract tagged limited record
      N : Natural;
   end record;

end MAT.Consoles;

Declare the Print_Size operation

Declare the Print_Size operation


-----------------------------------------------------------------------
--  encodes -- Encodes strings
--  Copyright (C) 2010, 2011 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.Text_IO;
with Ada.Command_Line;
with Util.Encoders;

procedure Encodes is

   use Util.Encoders;

   Encode : Boolean := True;
   Count  : constant Natural := Ada.Command_Line.Argument_Count;

begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: encodes {encoder} [-d|-e] string...");
      Ada.Text_IO.Put_Line ("Encoders: " & Util.Encoders.BASE_64 & ", "
                            & Util.Encoders.BASE_64_URL & ", "
                            & Util.Encoders.BASE_16);
      return;
   end if;
   declare
      Name : constant String := Ada.Command_Line.Argument (1);
      C    : constant Encoder := Util.Encoders.Create (Name);
   begin
      for I in 2 .. Count loop
         declare
            S : constant String := Ada.Command_Line.Argument (I);
         begin
            if S = "-d" then
               Encode := False;
            elsif S = "-e" then
               Encode := True;
            elsif Encode then
               Ada.Text_IO.Put_Line ("Encodes " & Name & ": " & C.Encode (S));
            else
               Ada.Text_IO.Put_Line ("Decodes " & Name & ": " & C.Decode (S));
            end if;
         end;
      end loop;
   end;
end Encodes;

-----------------------------------------------------------------------
--  encodes -- Encodes strings
--  Copyright (C) 2010, 2011 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.Text_IO;
with Ada.Command_Line;
with Util.Encoders;

procedure Encodes is

   use Util.Encoders;

   Encode : Boolean := True;
   Count  : constant Natural := Ada.Command_Line.Argument_Count;

begin
   if Count <= 1 then
      Ada.Text_IO.Put_Line ("Usage: encodes {encoder} [-d|-e] string...");
      Ada.Text_IO.Put_Line ("Encoders: " & Util.Encoders.BASE_64 & ", "
                            & Util.Encoders.BASE_64_URL & ", "
                            & Util.Encoders.BASE_16 & ", "
                            & Util.Encoders.HASH_SHA1);
      return;
   end if;
   declare
      Name : constant String := Ada.Command_Line.Argument (1);
      C    : constant Encoder := Util.Encoders.Create (Name);
   begin
      for I in 2 .. Count loop
         declare
            S : constant String := Ada.Command_Line.Argument (I);
         begin
            if S = "-d" then
               Encode := False;
            elsif S = "-e" then
               Encode := True;
            elsif Encode then
               Ada.Text_IO.Put_Line ("Encodes " & Name & ": " & C.Encode (S));
            else
               Ada.Text_IO.Put_Line ("Decodes " & Name & ": " & C.Decode (S));
            end if;
         end;
      end loop;
   end;
end Encodes;

Add sha1 encoding

Add sha1 encoding


-----------------------------------------------------------------------
--  schemas Tests -- Test loading of database schema
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017 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 Util.Test_Caller;

with ADO.Sessions;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "ID", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "NAME", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", Get_Name (C), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

end ADO.Schemas.Tests;

-----------------------------------------------------------------------
--  schemas Tests -- Test loading of database schema
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2017, 2018 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 Util.Test_Caller;
with Util.Strings.Transforms;

with ADO.Sessions;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

   package Caller is new Util.Test_Caller (Test, "ADO.Schemas");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
--           T1 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.USER_TABLE'Access);
--           T2 : constant ADO.Model.Entity_Type_Ref
--             := Entities.Find_Entity_Type (Cache => C,
--                                           Table => Regtests.Simple.Model.ALLOCATE_TABLE'Access);

         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
      begin
--           T.Assert (not ADO.Objects.Is_Null (T1), "Find_Entity_Type returned a null value");
--           T.Assert (not ADO.Objects.Is_Null (T2), "Find_Entity_Type returned a null value");

         T.Assert (T4 /= T5, "Two distinct tables have different entity types");
         T.Assert (T4 > 0, "T1.Id must be positive");
         T.Assert (T5 > 0, "T2.Id must be positive");
--           T.Assert (T1.Get_Id /= T2.Get_Id, "Two distinct tables have different ids");
--
--           Assert_Equals (T, Integer (T2.Get_Id), Integer (T4),
--                          "Invalid entity type for allocate_table");
--           Assert_Equals (T, Integer (T1.Get_Id), Integer (T5),
--                          "Invalid entity type for user_table");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 15, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 8, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

end ADO.Schemas.Tests;

Update the test to ignore the case of table and column names


-----------------------------------------------------------------------
--  mat-types -- Global types
--  Copyright (C) 2014, 2015 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.
-----------------------------------------------------------------------
package body MAT.Types is

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String is
      use type Interfaces.Unsigned_64;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint64 := Value;
      N : Uint64;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Format the target time to a printable representation.
   --  ------------------------------
   function Tick_Image (Value : in Target_Tick_Ref) return String is
      use Interfaces;

      Sec  : constant Unsigned_32 := Unsigned_32 (Interfaces.Shift_Right (Uint64 (Value), 32));
      Usec : constant Unsigned_32 := Interfaces.Unsigned_32 (Value and 16#0ffffffff#);
      Frac : constant String := Interfaces.Unsigned_32'Image (Usec);
      Img  : String (1 .. 6) := (others => '0');
   begin
      Img (Img'Last - Frac'Length + 2 .. Img'Last) := Frac (Frac'First + 1 .. Frac'Last);
      return Interfaces.Unsigned_32'Image (Sec) & "." & Img;
   end Tick_Image;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref is
      use Interfaces;

      Res   : Target_Tick_Ref := Target_Tick_Ref (Uint64 (Left) - Uint64 (Right));
      Usec1 : constant Unsigned_32 := Interfaces.Unsigned_32 (Left and 16#0ffffffff#);
      Usec2 : constant Unsigned_32 := Interfaces.Unsigned_32 (Right and 16#0ffffffff#);
   begin
      if Usec1 < Usec2 then
         Res := Res and 16#ffffffff00000000#;
         Res := Target_Tick_Ref (Uint64 (Res) - 16#100000000#);
         Res := Res or Target_Tick_Ref (1000000 - (Usec2 - Usec1));
      end if;
      return Res;
   end "-";

end MAT.Types;

-----------------------------------------------------------------------
--  mat-types -- Global types
--  Copyright (C) 2014, 2015 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.
-----------------------------------------------------------------------
package body MAT.Types is

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint32;
                       Length : in Positive := 8) return String is
      use type Interfaces.Unsigned_32;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint32 := Value;
      N : Uint32;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Return an hexadecimal string representation of the value.
   --  ------------------------------
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String is
      use type Interfaces.Unsigned_64;

      Conversion : constant String (1 .. 16) := "0123456789ABCDEF";
      S : String (1 .. Length) := (others => '0');
      P : Uint64 := Value;
      N : Uint64;
      I : Positive := Length;
   begin
      while P /= 0 loop
         N := P mod 16;
         P := P / 16;
         S (I) := Conversion (Natural (N + 1));
         exit when I = 1;
         I := I - 1;
      end loop;
      return S;
   end Hex_Image;

   --  ------------------------------
   --  Format the target time to a printable representation.
   --  ------------------------------
   function Tick_Image (Value : in Target_Tick_Ref) return String is
      use Interfaces;

      Sec  : constant Unsigned_32 := Unsigned_32 (Interfaces.Shift_Right (Uint64 (Value), 32));
      Usec : constant Unsigned_32 := Interfaces.Unsigned_32 (Value and 16#0ffffffff#);
      Frac : constant String := Interfaces.Unsigned_32'Image (Usec);
      Img  : String (1 .. 6) := (others => '0');
   begin
      Img (Img'Last - Frac'Length + 2 .. Img'Last) := Frac (Frac'First + 1 .. Frac'Last);
      return Interfaces.Unsigned_32'Image (Sec) & "." & Img;
   end Tick_Image;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref is
      use Interfaces;

      Res   : Target_Tick_Ref := Target_Tick_Ref (Uint64 (Left) - Uint64 (Right));
      Usec1 : constant Unsigned_32 := Interfaces.Unsigned_32 (Left and 16#0ffffffff#);
      Usec2 : constant Unsigned_32 := Interfaces.Unsigned_32 (Right and 16#0ffffffff#);
   begin
      if Usec1 < Usec2 then
         Res := Res and 16#ffffffff00000000#;
         Res := Target_Tick_Ref (Uint64 (Res) - 16#100000000#);
         Res := Res or Target_Tick_Ref (1000000 - (Usec2 - Usec1));
      end if;
      return Res;
   end "-";

   --  ------------------------------
   --  Convert the hexadecimal string into an unsigned integer.
   --  ------------------------------
   function Hex_Value (Value : in String) return Uint64 is
      use type Interfaces.Unsigned_64;

      Result : Uint64 := 0;
   begin
      if Value'Length = 0 then
         raise Constraint_Error with "Empty string";
      end if;
      for I in Value'Range loop
         declare
            C : constant Character := Value (I);
         begin
            if C >= '0' and C <= '9' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('0'));
            elsif C >= 'A' and C <= 'F' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('F') + 10);
            elsif C >= 'a' and C <= 'f' then
               Result := (Result * 16) + (Character'Pos (C) - Character'Pos ('f') + 10);
            else
               raise Constraint_Error with "Invalid character: " & C;
            end if;
         end;
      end loop;
      return Result;
   end Hex_Value;

end MAT.Types;

Implement the Hex_Value function to convert a hexadecimal string into a number