-----------------------------------------------------------------------
--  awa-helpers -- Helpers for AWA applications
--  Copyright (C) 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 ADO.Queries.Loaders;
with AWA.Services.Contexts;
package body AWA.Helpers.Selectors is

   --  ------------------------------
   --  Create a selector list from the definition of a discrete type such as an enum.
   --  The select item has the enum value as value and the label is created by
   --  localizing the string Prefix_enum name.
   --  ------------------------------
   function Create_From_Enum (Bundle : in Util.Properties.Bundles.Manager'Class)
                              return ASF.Models.Selects.Select_Item_List is
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      for I in T'Range loop
         declare
            Value : constant String := T'Image (I);
            Name  : constant String := Prefix & "_" & Value;
            Label : constant String := Bundle.Get (Name, Name);
         begin
            Result.Append (ASF.Models.Selects.Create_Select_Item (Label, Value));
         end;
      end loop;
      return Result;
   end Create_From_Enum;

   --  ------------------------------
   --  Append the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   procedure Append_From_Query (Into  : in out ASF.Models.Selects.Select_Item_List;
                                Query : in out ADO.Statements.Query_Statement'Class) is
   begin
      Query.Execute;
      while Query.Has_Elements loop
         declare
            Id    : constant String := Query.Get_String (1);
            Label : constant String := Query.Get_String (2);
         begin
            Into.Append (ASF.Models.Selects.Create_Select_Item (Id, Label));
         end;
         Query.Next;
      end loop;
   end Append_From_Query;

   --  ------------------------------
   --  Create the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   function Create_From_Query (Session : in ADO.Sessions.Session'Class;
                               Query   : in ADO.Queries.Context'Class)
                               return ASF.Models.Selects.Select_Item_List is
      Stmt   : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      Append_From_Query (Result, Stmt);
      return Result;
   end Create_From_Query;

   --  ------------------------------
   --  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 Select_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "list" then
         return ASF.Models.Selects.To_Object (From.List);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   procedure Set_Value (From  : in out Select_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      use type AWA.Services.Contexts.Service_Context_Access;
      use type ADO.Queries.Query_Definition_Access;
   begin
      if Name = "query" then
         declare
            Query_Name : constant String := Util.Beans.Objects.To_String (Value);
            Ctx : constant AWA.Services.Contexts.Service_Context_Access
              := AWA.Services.Contexts.Current;
            Query_Def : constant ADO.Queries.Query_Definition_Access
              := ADO.Queries.Loaders.Find_Query (Query_Name);
            Query     : ADO.Queries.Context;
         begin
            if Ctx = null or Query_Def = null then
               return;
            end if;

            Query.Set_Query (Query_Def);
            From.List := Create_From_Query (Session => AWA.Services.Contexts.Get_Session (Ctx),
                                            Query   => Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the select list bean instance.
   --  ------------------------------
   function Create_Select_List_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Select_List_Bean_Access := new Select_List_Bean;
   begin
      return Result.all'Access;
   end Create_Select_List_Bean;

end AWA.Helpers.Selectors;

-----------------------------------------------------------------------
--  awa-helpers -- Helpers for AWA applications
--  Copyright (C) 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 ADO.Queries.Loaders;
with ADO.Schemas;

with Util.Strings;
with Util.Log.Loggers;

with AWA.Services.Contexts;
package body AWA.Helpers.Selectors is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Helpers.Selectors");

   --  ------------------------------
   --  Create a selector list from the definition of a discrete type such as an enum.
   --  The select item has the enum value as value and the label is created by
   --  localizing the string Prefix_enum name.
   --  ------------------------------
   function Create_From_Enum (Bundle : in Util.Properties.Bundles.Manager'Class)
                              return ASF.Models.Selects.Select_Item_List is
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      for I in T'Range loop
         declare
            Value : constant String := T'Image (I);
            Name  : constant String := Prefix & "_" & Value;
            Label : constant String := Bundle.Get (Name, Name);
         begin
            Result.Append (ASF.Models.Selects.Create_Select_Item (Label, Value));
         end;
      end loop;
      return Result;
   end Create_From_Enum;

   --  ------------------------------
   --  Append the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   procedure Append_From_Query (Into  : in out ASF.Models.Selects.Select_Item_List;
                                Query : in out ADO.Statements.Query_Statement'Class) is
      use ADO.Schemas;

      Id_Type    : ADO.Schemas.Column_Type := T_UNKNOWN;
      Label_Type : ADO.Schemas.Column_Type := T_UNKNOWN;

      function Get_Column (Id : in Natural;
                           Of_Type : in ADO.Schemas.Column_Type) return String is
      begin
         case Of_Type is
            when T_CHAR | T_VARCHAR =>
               return Query.Get_String (Id);

            when T_INTEGER | T_TINYINT | T_SMALLINT | T_ENUM =>
               return Util.Strings.Image (Query.Get_Integer (Id));

            when T_LONG_INTEGER =>
               return Util.Strings.Image (Long_Long_Integer (Query.Get_Int64 (Id)));

            when others =>
               return "";

         end case;
      end Get_Column;

   begin
      Query.Execute;
      while Query.Has_Elements loop
         if Id_Type = T_UNKNOWN then
            Id_Type    := Query.Get_Column_Type (0);
            Label_Type := Query.Get_Column_Type (1);
         end if;
         declare
            Id    : constant String := Get_Column (0, Id_Type);
            Label : constant String := Get_Column (1, Label_Type);
         begin
            Into.Append (ASF.Models.Selects.Create_Select_Item (Label => Label, Value => Id));
         end;
         Query.Next;
      end loop;
   end Append_From_Query;

   --  ------------------------------
   --  Create the selector list from the SQL query.  The query will be executed.
   --  It should return rows with at least two columns.  The first column is the
   --  selector value and the second column is the selector label.
   --  ------------------------------
   function Create_From_Query (Session : in ADO.Sessions.Session'Class;
                               Query   : in ADO.Queries.Context'Class)
                               return ASF.Models.Selects.Select_Item_List is
      Stmt   : ADO.Statements.Query_Statement := Session.Create_Statement (Query);
      Result : ASF.Models.Selects.Select_Item_List;
   begin
      Append_From_Query (Result, Stmt);
      return Result;
   end Create_From_Query;

   --  ------------------------------
   --  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 Select_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "list" then
         return ASF.Models.Selects.To_Object (From.List);
      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   procedure Set_Value (From  : in out Select_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      use type AWA.Services.Contexts.Service_Context_Access;
      use type ADO.Queries.Query_Definition_Access;
   begin
      if Name = "query" then
         declare
            Query_Name : constant String := Util.Beans.Objects.To_String (Value);
            Ctx : constant AWA.Services.Contexts.Service_Context_Access
              := AWA.Services.Contexts.Current;
            Query_Def : constant ADO.Queries.Query_Definition_Access
              := ADO.Queries.Loaders.Find_Query (Query_Name);
            Query     : ADO.Queries.Context;
         begin
            if Ctx = null or Query_Def = null then
               return;
            end if;

            Query.Set_Query (Query_Def);
            From.List := Create_From_Query (Session => AWA.Services.Contexts.Get_Session (Ctx),
                                            Query   => Query);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the select list bean instance.
   --  ------------------------------
   function Create_Select_List_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Select_List_Bean_Access := new Select_List_Bean;
   begin
      return Result.all'Access;
   end Create_Select_List_Bean;

end AWA.Helpers.Selectors;

Use the column type to decide which column fetch operation must be used


-----------------------------------------------------------------------
--  awa-services -- Services
--  Copyright (C) 2011, 2012, 2013 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.Task_Attributes;
with ADO.Databases;

package body AWA.Services.Contexts is

   use type ADO.Databases.Connection_Status;
   use type AWA.Users.Principals.Principal_Access;

   package Task_Context is new Ada.Task_Attributes
     (Service_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_Application (Ctx : in Service_Context)
                             return AWA.Applications.Application_Access is
   begin
      return Ctx.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the current database connection for reading.
   --  ------------------------------
   function Get_Session (Ctx : in Service_Context_Access) return ADO.Sessions.Session is
   begin
      --  If a master database session was created, use it.
      if Ctx.Master.Get_Status = ADO.Databases.OPEN then
         return ADO.Sessions.Session (Ctx.Master);

      elsif Ctx.Slave.Get_Status /= ADO.Databases.OPEN then
         Ctx.Slave  := Ctx.Application.Get_Session;
      end if;
      return Ctx.Slave;
   end Get_Session;

   --  ------------------------------
   --  Get the current database connection for reading and writing.
   --  ------------------------------
   function Get_Master_Session (Ctx : in Service_Context_Access)
                                return ADO.Sessions.Master_Session is
   begin
      if Ctx.Master.Get_Status /= ADO.Databases.OPEN then
         Ctx.Master := Ctx.Application.Get_Master_Session;
      end if;
      return Ctx.Master;
   end Get_Master_Session;

   --  ------------------------------
   --  Get the current user invoking the service operation.
   --  Returns a null user if there is none.
   --  ------------------------------
   function Get_User (Ctx : in Service_Context) return AWA.Users.Models.User_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_User;
      else
         return Ctx.Principal.Get_User;
      end if;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (Ctx : in Service_Context) return ADO.Identifier is
   begin
      if Ctx.Principal = null then
         return ADO.NO_IDENTIFIER;
      else
         return Ctx.Principal.Get_User_Identifier;
      end if;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the current user session from the user invoking the service operation.
   --  Returns a null session if there is none.
   --  ------------------------------
   function Get_User_Session (Ctx : in Service_Context) return AWA.Users.Models.Session_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_Session;
      else
         return Ctx.Principal.Get_Session;
      end if;
   end Get_User_Session;

   --  ------------------------------
   --  Starts a transaction.
   --  ------------------------------
   procedure Start (Ctx : in out Service_Context) is
   begin
      if Ctx.Transaction = 0 and then not Ctx.Active_Transaction then
         Ctx.Master.Begin_Transaction;
         Ctx.Active_Transaction := True;
      end if;
      Ctx.Transaction := Ctx.Transaction + 1;
   end Start;

   --  ------------------------------
   --  Commits the current transaction.  The database transaction is really committed by the
   --  last Commit called.
   --  ------------------------------
   procedure Commit (Ctx : in out Service_Context) is
   begin
      Ctx.Transaction := Ctx.Transaction - 1;
      if Ctx.Transaction = 0 and then Ctx.Active_Transaction then
         Ctx.Master.Commit;
         Ctx.Active_Transaction := False;
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.  The database transaction is rollback at the first
   --  call to Rollback.
   --  ------------------------------
   procedure Rollback (Ctx : in out Service_Context) is
   begin
      null;
   end Rollback;

   --  ------------------------------
   --  Get the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   function Get_Session_Attribute (Ctx  : in Service_Context;
                                   Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Ctx, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Session_Attribute;

   --  ------------------------------
   --  Set the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   procedure Set_Session_Attribute (Ctx   : in out Service_Context;
                                    Name  : in String;
                                    Value : in Util.Beans.Objects.Object) is
   begin
      null;
   end Set_Session_Attribute;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Ctx         : in out Service_Context;
                          Application : in AWA.Applications.Application_Access;
                          Principal   : in AWA.Users.Principals.Principal_Access) is
   begin
      Ctx.Application := Application;
      Ctx.Principal   := Principal;
   end Set_Context;

   --  ------------------------------
   --  Initializes the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Ctx : in out Service_Context) is
      use type AWA.Applications.Application_Access;
   begin
      Ctx.Previous := Task_Context.Value;
      Task_Context.Set_Value (Ctx'Unchecked_Access);
      if Ctx.Previous /= null and then Ctx.Application = null then
         Ctx.Application := Ctx.Previous.Application;
      end if;
   end Initialize;

   --  ------------------------------
   --  Finalize the service context, rollback non-committed transaction, releases any object.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Service_Context) is
   begin
      --  When the service context is released, we must not have any active transaction.
      --  This means we are leaving the service in an abnormal way such as when an
      --  exception is raised.  If this is the case, rollback the transaction.
      if Ctx.Active_Transaction then
         Ctx.Master.Rollback;
      end if;
      Task_Context.Set_Value (Ctx.Previous);
   end Finalize;

   --  ------------------------------
   --  Get the current service context.
   --  Returns null if the current thread is not associated with any service context.
   --  ------------------------------
   function Current return Service_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

end AWA.Services.Contexts;

-----------------------------------------------------------------------
--  awa-services -- Services
--  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 Ada.Task_Attributes;
with ADO.Databases;

package body AWA.Services.Contexts is

   use type ADO.Databases.Connection_Status;
   use type AWA.Users.Principals.Principal_Access;

   package Task_Context is new Ada.Task_Attributes
     (Service_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_Application (Ctx : in Service_Context)
                             return AWA.Applications.Application_Access is
   begin
      return Ctx.Application;
   end Get_Application;

   --  ------------------------------
   --  Get the current database connection for reading.
   --  ------------------------------
   function Get_Session (Ctx : in Service_Context_Access) return ADO.Sessions.Session is
   begin
      --  If a master database session was created, use it.
      if Ctx.Master.Get_Status = ADO.Databases.OPEN then
         return ADO.Sessions.Session (Ctx.Master);

      elsif Ctx.Slave.Get_Status /= ADO.Databases.OPEN then
         Ctx.Slave  := Ctx.Application.Get_Session;
      end if;
      return Ctx.Slave;
   end Get_Session;

   --  ------------------------------
   --  Get the current database connection for reading and writing.
   --  ------------------------------
   function Get_Master_Session (Ctx : in Service_Context_Access)
                                return ADO.Sessions.Master_Session is
   begin
      if Ctx.Master.Get_Status /= ADO.Databases.OPEN then
         Ctx.Master := Ctx.Application.Get_Master_Session;
      end if;
      return Ctx.Master;
   end Get_Master_Session;

   --  ------------------------------
   --  Get the current user invoking the service operation.
   --  Returns a null user if there is none.
   --  ------------------------------
   function Get_User (Ctx : in Service_Context) return AWA.Users.Models.User_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_User;
      else
         return Ctx.Principal.Get_User;
      end if;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (Ctx : in Service_Context) return ADO.Identifier is
   begin
      if Ctx.Principal = null then
         return ADO.NO_IDENTIFIER;
      else
         return Ctx.Principal.Get_User_Identifier;
      end if;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the current user session from the user invoking the service operation.
   --  Returns a null session if there is none.
   --  ------------------------------
   function Get_User_Session (Ctx : in Service_Context) return AWA.Users.Models.Session_Ref is
   begin
      if Ctx.Principal = null then
         return AWA.Users.Models.Null_Session;
      else
         return Ctx.Principal.Get_Session;
      end if;
   end Get_User_Session;

   --  ------------------------------
   --  Starts a transaction.
   --  ------------------------------
   procedure Start (Ctx : in out Service_Context) is
   begin
      if Ctx.Transaction = 0 and then not Ctx.Active_Transaction then
         Ctx.Master.Begin_Transaction;
         Ctx.Active_Transaction := True;
      end if;
      Ctx.Transaction := Ctx.Transaction + 1;
   end Start;

   --  ------------------------------
   --  Commits the current transaction.  The database transaction is really committed by the
   --  last Commit called.
   --  ------------------------------
   procedure Commit (Ctx : in out Service_Context) is
   begin
      Ctx.Transaction := Ctx.Transaction - 1;
      if Ctx.Transaction = 0 and then Ctx.Active_Transaction then
         Ctx.Master.Commit;
         Ctx.Active_Transaction := False;
      end if;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.  The database transaction is rollback at the first
   --  call to Rollback.
   --  ------------------------------
   procedure Rollback (Ctx : in out Service_Context) is
   begin
      null;
   end Rollback;

   --  ------------------------------
   --  Get the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   function Get_Session_Attribute (Ctx  : in Service_Context;
                                   Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Ctx, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Session_Attribute;

   --  ------------------------------
   --  Set the attribute registered under the given name in the HTTP session.
   --  ------------------------------
   procedure Set_Session_Attribute (Ctx   : in out Service_Context;
                                    Name  : in String;
                                    Value : in Util.Beans.Objects.Object) is
   begin
      null;
   end Set_Session_Attribute;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Ctx         : in out Service_Context;
                          Application : in AWA.Applications.Application_Access;
                          Principal   : in AWA.Users.Principals.Principal_Access) is
   begin
      Ctx.Application := Application;
      Ctx.Principal   := Principal;
   end Set_Context;

   --  ------------------------------
   --  Initializes the service context.
   --  ------------------------------
   overriding
   procedure Initialize (Ctx : in out Service_Context) is
      use type AWA.Applications.Application_Access;
   begin
      Ctx.Previous := Task_Context.Value;
      Task_Context.Set_Value (Ctx'Unchecked_Access);
      if Ctx.Previous /= null and then Ctx.Application = null then
         Ctx.Application := Ctx.Previous.Application;
      end if;
   end Initialize;

   --  ------------------------------
   --  Finalize the service context, rollback non-committed transaction, releases any object.
   --  ------------------------------
   overriding
   procedure Finalize (Ctx : in out Service_Context) is
   begin
      --  When the service context is released, we must not have any active transaction.
      --  This means we are leaving the service in an abnormal way such as when an
      --  exception is raised.  If this is the case, rollback the transaction.
      if Ctx.Active_Transaction then
         Ctx.Master.Rollback;
      end if;
      Task_Context.Set_Value (Ctx.Previous);
   end Finalize;

   --  ------------------------------
   --  Get the current service context.
   --  Returns null if the current thread is not associated with any service context.
   --  ------------------------------
   function Current return Service_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Run the process procedure on behalf of the specific user and session.
   --  This operation changes temporarily the identity of the current user principal and
   --  executes the <tt>Process</tt> procedure.
   --  ------------------------------
   procedure Run_As (User    : in AWA.Users.Models.User_Ref;
                     Session : in AWA.Users.Models.Session_Ref) is
      Ctx       : Service_Context;
      Principal : aliased AWA.Users.Principals.Principal
        := AWA.Users.Principals.Create (User, Session);
   begin
      Ctx.Principal := Principal'Unchecked_Access;
      Process;
   end Run_As;

end AWA.Services.Contexts;

Implement the Run_As by creating a local service context with a user principal and calling the process procedure. When we return (normal return or from an exception), the previous service context is restored


-----------------------------------------------------------------------
--  wiki-parsers-html -- Wiki HTML parser
--  Copyright (C) 2015, 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 Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString) is
      C : Wiki.Strings.WChar;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Wide_Wide_Builders.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
--      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Wide_Wide_Builders.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      procedure Append_Attribute (Name : in Wiki.Strings.WString);

      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.BString (64);
      Value : Wiki.Strings.BString (256);

      procedure Append_Attribute (Name : in Wiki.Strings.WString) is

         procedure Attribute_Value (Value : in Wiki.Strings.WString);

         procedure Attribute_Value (Value : in Wiki.Strings.WString) is
         begin
            Attributes.Append (P.Attributes, Name, Value);
         end Attribute_Value;

         procedure Attribute_Value is
           new Wiki.Strings.Wide_Wide_Builders.Get (Attribute_Value);
         pragma Inline (Attribute_Value);

      begin
         Attribute_Value (Value);
      end Append_Attribute;
      pragma Inline (Append_Attribute);

      procedure Append_Attribute is
        new Wiki.Strings.Wide_Wide_Builders.Get (Append_Attribute);

   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Value);
         elsif Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
            Put_Back (P, C);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
         end if;
      end loop;

      --  Add any pending attribute.
      if Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
         Append_Attribute (Name);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      C    : Wiki.Strings.WChar;

      procedure Add_Element (Token : in Wiki.Strings.WString);

      procedure Add_Element (Token : in Wiki.Strings.WString) is
         Tag  : Wiki.Html_Tag;
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := False;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := True;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end Add_Element;
      pragma Inline (Add_Element);

      procedure Add_Element is
        new Wiki.Strings.Wide_Wide_Builders.Get (Add_Element);
      pragma Inline (Add_Element);

      Name : Wiki.Strings.BString (64);
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Add_Element (Name);
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

-----------------------------------------------------------------------
--  wiki-parsers-html -- Wiki HTML parser
--  Copyright (C) 2015, 2016, 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 Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString);

   function Is_Letter (C : in Wiki.Strings.WChar) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Wiki.Strings.BString) is
      C : Wiki.Strings.WChar;
   begin
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Wiki.Strings.Wide_Wide_Builders.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Wiki.Strings.BString) is
      C     : Wiki.Strings.WChar;
      Token : Wiki.Strings.WChar;
   begin
--      Value := Wiki.Strings.To_UString ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Wiki.Strings.Wide_Wide_Builders.Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Wiki.Strings.Wide_Wide_Builders.Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      procedure Append_Attribute (Name : in Wiki.Strings.WString);

      C     : Wiki.Strings.WChar;
      Name  : Wiki.Strings.BString (64);
      Value : Wiki.Strings.BString (256);

      procedure Append_Attribute (Name : in Wiki.Strings.WString) is

         procedure Attribute_Value (Value : in Wiki.Strings.WString);

         procedure Attribute_Value (Value : in Wiki.Strings.WString) is
         begin
            Attributes.Append (P.Attributes, Name, Value);
         end Attribute_Value;

         procedure Attribute_Value is
           new Wiki.Strings.Wide_Wide_Builders.Get (Attribute_Value);
         pragma Inline (Attribute_Value);

      begin
         Attribute_Value (Value);
      end Append_Attribute;
      pragma Inline (Append_Attribute);

      procedure Append_Attribute is
        new Wiki.Strings.Wide_Wide_Builders.Get (Append_Attribute);

   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Value);
         elsif Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
            Put_Back (P, C);
            Append_Attribute (Name);
            Wiki.Strings.Wide_Wide_Builders.Clear (Name);
         end if;
      end loop;

      --  Add any pending attribute.
      if Wiki.Strings.Wide_Wide_Builders.Length (Name) > 0 then
         Append_Attribute (Name);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wiki.Strings.WChar;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wiki.Strings.WChar;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      C    : Wiki.Strings.WChar;

      procedure Add_Element (Token : in Wiki.Strings.WString);

      procedure Add_Element (Token : in Wiki.Strings.WString) is
         Tag  : Wiki.Html_Tag;
      begin
         Tag := Wiki.Find_Tag (Token);
         if C = '/' then
            Skip_Spaces (P);
            Peek (P, C);
            if C /= '>' then
               Put_Back (P, C);
            end if;
            Flush_Text (P);
            if Tag = Wiki.UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               end if;
            else
               End_Element (P, Tag);
            end if;
         else
            Collect_Attributes (P);
            Peek (P, C);
            if C = '/' then
               Peek (P, C);
               if C = '>' then
                  Start_Element (P, Tag, P.Attributes);
                  End_Element (P, Tag);
                  return;
               end if;
            elsif C /= '>' then
               Put_Back (P, C);
            end if;
            if Tag = UNKNOWN_TAG then
               if Token = "noinclude" then
                  P.Context.Is_Hidden := P.Context.Is_Included;
               elsif Token = "includeonly" then
                  P.Context.Is_Hidden := not P.Context.Is_Included;
               end if;
            else
               Start_Element (P, Tag, P.Attributes);
            end if;
         end if;
      end Add_Element;
      pragma Inline (Add_Element);

      procedure Add_Element is
        new Wiki.Strings.Wide_Wide_Builders.Get (Add_Element);
      pragma Inline (Add_Element);

      Name : Wiki.Strings.BString (64);
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Add_Element (Name);
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wiki.Strings.WChar) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wiki.Strings.WChar;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Wiki.Strings.To_Char (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Wiki.Strings.To_WChar (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

Fix the <noinclude> to take into account the template rendering as a non-inclusion file Add support for <includeonly> in templates


-----------------------------------------------------------------------
--  util-encodes-tests - Test for encoding
--  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 Util.Test_Caller;
with Util.Tests;
with Util.Measures;
with Util.Strings.Transforms;
with Ada.Text_IO;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
--  with Util.Log.Loggers;
package body Util.Encoders.Tests is

   use Util.Tests;
--     use Util.Log;
--
--     Log : constant Loggers.Logger := Loggers.Create ("Util.Encoders.Tests");

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Encode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Decode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Encode",
                       Test_Base64_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Decode",
                       Test_Base64_Decode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Benchmark",
                       Test_Base64_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Encode",
                       Test_SHA1_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Benchmark",
                       Test_SHA1_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test1)",
                       Test_HMAC_SHA1_RFC2202_T1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test2)",
                       Test_HMAC_SHA1_RFC2202_T2'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test3)",
                       Test_HMAC_SHA1_RFC2202_T3'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test4)",
                       Test_HMAC_SHA1_RFC2202_T4'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test5)",
                       Test_HMAC_SHA1_RFC2202_T5'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test6)",
                       Test_HMAC_SHA1_RFC2202_T6'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test7)",
                       Test_HMAC_SHA1_RFC2202_T7'Access);
   end Add_Tests;

   procedure Test_Base64_Encode (T : in out Test) is
      C : constant Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "YQ==", Util.Encoders.Encode (C, "a"));
      Assert_Equals (T, "fA==", Util.Encoders.Encode (C, "|"));
      Assert_Equals (T, "fHw=", Util.Encoders.Encode (C, "||"));
      Assert_Equals (T, "fH5+", Util.Encoders.Encode (C, "|~~"));
   end Test_Base64_Encode;

   procedure Test_Base64_Decode (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "a", Util.Encoders.Decode (C, "YQ=="));
      Assert_Equals (T, "|", Util.Encoders.Decode (C, "fA=="));
      Assert_Equals (T, "||", Util.Encoders.Decode (C, "fHw="));
      Assert_Equals (T, "|~~", Util.Encoders.Decode (C, "fH5+"));
      Test_Encoder (T, C);
   end Test_Base64_Decode;

   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder) is
   begin
      for I in 1 .. 334 loop
         declare
            Pattern : String (1 .. I);
         begin
            for J in Pattern'Range loop
               Pattern (J) := Character'Val (((J + I) mod 63) + 32);
            end loop;
            declare
               E : constant String := Util.Encoders.Encode (C, Pattern);
               D : constant String := Util.Encoders.Decode (C, E);
            begin
               Assert_Equals (T, Pattern, D, "Encoding failed for length "
                              & Integer'Image (I));
            end;
         exception
            when others =>
               Ada.Text_IO.Put_Line ("Error at index " & Integer'Image (I));
               raise;
         end;
      end loop;
   end Test_Encoder;

   procedure Test_Hex (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("hex");
   begin
      Assert_Equals (T, "41424344", Util.Encoders.Encode(C, "ABCD"));
      Assert_Equals (T, "ABCD", Util.Encoders.Decode (C, "41424344"));
      Test_Encoder (T, C);
   end Test_Hex;

   procedure Test_Base64_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      C : constant Util.Encoders.Encoder := Create ("base64");
      S : constant String (1 .. 1_024) := (others => 'a');
   begin
      declare
         T : Util.Measures.Stamp;
         R : constant String := Util.Encoders.Encode (C, S);
         pragma Unreferenced (R);
      begin
         Util.Measures.Report (T, "Base64 encode 1024 bytes");
      end;
   end Test_Base64_Benchmark;

   procedure Test_SHA1_Encode (T : in out Test) is
      C    : Util.Encoders.SHA1.Context;
      Hash : Util.Encoders.SHA1.Digest;

      procedure Check_Hash (Value  : in String;
                            Expect : in String) is
         J, N : Natural;
         Ctx  : Util.Encoders.SHA1.Context;
      begin
         for I in 1 .. Value'Length loop
            J := Value'First;
            while J <= Value'Last loop
               if J + I <= Value'Last then
                  N := J + I;
               else
                  N := Value'Last;
               end if;
               Util.Encoders.SHA1.Update (Ctx, Value (J .. N));
               J := N + 1;
            end loop;
            Util.Encoders.SHA1.Finish (Ctx, Hash);
            Assert_Equals (T, Expect, Hash, "Invalid hash for: " & Value);
         end loop;
      end Check_Hash;

   begin
      Util.Encoders.SHA1.Update (C, "a");
      Util.Encoders.SHA1.Finish (C, Hash);

      Assert_Equals (T, "86F7E437FAA5A7FCE15D1DDCB9EAEAEA377667B8", Hash,
                     "Invalid hash for 'a'");

      Check_Hash ("ut", "E746699D3947443D84DAD1E0C58BF7AD34712438");
      Check_Hash ("Uti", "2C669751BDC4929377245F5EEBEAED1CE4DA8A45");
      Check_Hash ("Util", "4C31156EFED35EE7814650F8971C3698059440E3");
      Check_Hash ("Util.Encoders", "7DB6007AD8BAEA7C167FF2AE06C9F50A4645F971");
      Check_Hash ("e746699d3947443d84dad1e0c58bf7ad347124382C669751BDC492937"
                  & "7245F5EEBEAED1CE4DA8A45",
                  "875C9C0DE4CE91ED8F432DD02B5BB40CD35DAACD");
   end Test_SHA1_Encode;

   --  ------------------------------
   --  Benchmark test for SHA1
   --  ------------------------------
   procedure Test_SHA1_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      Hash  : Util.Encoders.SHA1.Digest;
      Sizes : constant array (1 .. 6) of Positive := (1, 10, 100, 1000, 10000, 100000);
   begin
      for I in Sizes'Range loop
         declare
            Size : constant Positive := Sizes (I);
            S    : constant String (1 .. Size) := (others => '0');
            T1   : Util.Measures.Stamp;
            C    : Util.Encoders.SHA1.Context;
         begin
            Util.Encoders.SHA1.Update (C, S);
            Util.Encoders.SHA1.Finish (C, Hash);

            Util.Measures.Report (T1, "Encode SHA1" & Integer'Image (Size) & " bytes");
         end;
      end loop;
   end Test_SHA1_Benchmark;

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String) is
      H : constant String := Util.Encoders.HMAC.SHA1.Sign (Key, Value);
   begin
      Assert_Equals (T, Expect, Util.Strings.Transforms.To_Lower_Case (H),
                     "Invalid HMAC-SHA1");
   end Check_HMAC;

   --  ------------------------------
   --  Test HMAC-SHA1
   --  ------------------------------
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test) is
      Key : constant String (1 .. 20) := (others => Character'Val (16#0b#));
   begin
      Check_HMAC (T, Key, "Hi There", "b617318655057264e28bc0b6fb378c8ef146be00");
   end Test_HMAC_SHA1_RFC2202_T1;

   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test) is
   begin
      Check_HMAC (T, "Jefe", "what do ya want for nothing?",
                  "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79");
   end Test_HMAC_SHA1_RFC2202_T2;

   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#aa#));
      Data : constant String (1 .. 50) := (others => Character'Val (16#dd#));
   begin
      Check_HMAC (T, Key, Data,
                  "125d7342b9ac11cd91a39af48aa17b4f63f175d3");
   end Test_HMAC_SHA1_RFC2202_T3;

   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test) is
      C    : constant Util.Encoders.Encoder := Create ("hex");
      Key  : constant String := Util.Encoders.Decode (C, "0102030405060708090a0b0c0d0e0f10111213141516171819");
      Data : constant String (1 .. 50) := (others => Character'Val (16#cd#));
   begin
      Check_HMAC (T, Key, Data,
                  "4c9007f4026250c6bc8414f9bf50c86c2d7235da");
   end Test_HMAC_SHA1_RFC2202_T4;

   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#0c#));
   begin
      --  RFC2202 test case 5 but without truncation...
      Check_HMAC (T, Key, "Test With Truncation",
                  "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04");
   end Test_HMAC_SHA1_RFC2202_T5;

   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key - Hash Key First",
                  "aa4ae5e15272d00e95705637ce8a3b55ed402112");
   end Test_HMAC_SHA1_RFC2202_T6;

   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#Aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key and Larger "
                    & "Than One Block-Size Data",
                  "e8e99d0f45237d786d6bbaa7965c7808bbff1a91");
   end Test_HMAC_SHA1_RFC2202_T7;

end Util.Encoders.Tests;

-----------------------------------------------------------------------
--  util-encodes-tests - Test for encoding
--  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 Util.Test_Caller;
with Util.Measures;
with Util.Strings.Transforms;
with Ada.Text_IO;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
package body Util.Encoders.Tests is

   use Util.Tests;
--     use Util.Log;
--
--     Log : constant Loggers.Logger := Loggers.Create ("Util.Encoders.Tests");

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Encode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base16.Decode",
                       Test_Hex'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Encode",
                       Test_Base64_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Decode",
                       Test_Base64_Decode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.Base64.Benchmark",
                       Test_Base64_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Encode",
                       Test_SHA1_Encode'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.SHA1.Benchmark",
                       Test_SHA1_Benchmark'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test1)",
                       Test_HMAC_SHA1_RFC2202_T1'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test2)",
                       Test_HMAC_SHA1_RFC2202_T2'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test3)",
                       Test_HMAC_SHA1_RFC2202_T3'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test4)",
                       Test_HMAC_SHA1_RFC2202_T4'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test5)",
                       Test_HMAC_SHA1_RFC2202_T5'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test6)",
                       Test_HMAC_SHA1_RFC2202_T6'Access);
      Caller.Add_Test (Suite, "Test Util.Encoders.HMAC.SHA1.Sign_SHA1 (RFC2202 test7)",
                       Test_HMAC_SHA1_RFC2202_T7'Access);
   end Add_Tests;

   procedure Test_Base64_Encode (T : in out Test) is
      C : constant Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "YQ==", Util.Encoders.Encode (C, "a"));
      Assert_Equals (T, "fA==", Util.Encoders.Encode (C, "|"));
      Assert_Equals (T, "fHw=", Util.Encoders.Encode (C, "||"));
      Assert_Equals (T, "fH5+", Util.Encoders.Encode (C, "|~~"));
   end Test_Base64_Encode;

   procedure Test_Base64_Decode (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("base64");
   begin
      Assert_Equals (T, "a", Util.Encoders.Decode (C, "YQ=="));
      Assert_Equals (T, "|", Util.Encoders.Decode (C, "fA=="));
      Assert_Equals (T, "||", Util.Encoders.Decode (C, "fHw="));
      Assert_Equals (T, "|~~", Util.Encoders.Decode (C, "fH5+"));
      Test_Encoder (T, C);
   end Test_Base64_Decode;

   procedure Test_Encoder (T : in out Test;
                           C : in out Util.Encoders.Encoder) is
   begin
      for I in 1 .. 334 loop
         declare
            Pattern : String (1 .. I);
         begin
            for J in Pattern'Range loop
               Pattern (J) := Character'Val (((J + I) mod 63) + 32);
            end loop;
            declare
               E : constant String := Util.Encoders.Encode (C, Pattern);
               D : constant String := Util.Encoders.Decode (C, E);
            begin
               Assert_Equals (T, Pattern, D, "Encoding failed for length "
                              & Integer'Image (I));
            end;
         exception
            when others =>
               Ada.Text_IO.Put_Line ("Error at index " & Integer'Image (I));
               raise;
         end;
      end loop;
   end Test_Encoder;

   procedure Test_Hex (T : in out Test) is
      C : Util.Encoders.Encoder := Create ("hex");
   begin
      Assert_Equals (T, "41424344", Util.Encoders.Encode (C, "ABCD"));
      Assert_Equals (T, "ABCD", Util.Encoders.Decode (C, "41424344"));
      Test_Encoder (T, C);
   end Test_Hex;

   procedure Test_Base64_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      C : constant Util.Encoders.Encoder := Create ("base64");
      S : constant String (1 .. 1_024) := (others => 'a');
   begin
      declare
         T : Util.Measures.Stamp;
         R : constant String := Util.Encoders.Encode (C, S);
         pragma Unreferenced (R);
      begin
         Util.Measures.Report (T, "Base64 encode 1024 bytes");
      end;
   end Test_Base64_Benchmark;

   procedure Test_SHA1_Encode (T : in out Test) is
      procedure Check_Hash (Value  : in String;
                            Expect : in String);

      C    : Util.Encoders.SHA1.Context;
      Hash : Util.Encoders.SHA1.Digest;

      procedure Check_Hash (Value  : in String;
                            Expect : in String) is
         J, N : Natural;
         Ctx  : Util.Encoders.SHA1.Context;
      begin
         for I in 1 .. Value'Length loop
            J := Value'First;
            while J <= Value'Last loop
               if J + I <= Value'Last then
                  N := J + I;
               else
                  N := Value'Last;
               end if;
               Util.Encoders.SHA1.Update (Ctx, Value (J .. N));
               J := N + 1;
            end loop;
            Util.Encoders.SHA1.Finish (Ctx, Hash);
            Assert_Equals (T, Expect, Hash, "Invalid hash for: " & Value);
         end loop;
      end Check_Hash;

   begin
      Util.Encoders.SHA1.Update (C, "a");
      Util.Encoders.SHA1.Finish (C, Hash);

      Assert_Equals (T, "86F7E437FAA5A7FCE15D1DDCB9EAEAEA377667B8", Hash,
                     "Invalid hash for 'a'");

      Check_Hash ("ut", "E746699D3947443D84DAD1E0C58BF7AD34712438");
      Check_Hash ("Uti", "2C669751BDC4929377245F5EEBEAED1CE4DA8A45");
      Check_Hash ("Util", "4C31156EFED35EE7814650F8971C3698059440E3");
      Check_Hash ("Util.Encoders", "7DB6007AD8BAEA7C167FF2AE06C9F50A4645F971");
      Check_Hash ("e746699d3947443d84dad1e0c58bf7ad347124382C669751BDC492937"
                  & "7245F5EEBEAED1CE4DA8A45",
                  "875C9C0DE4CE91ED8F432DD02B5BB40CD35DAACD");
   end Test_SHA1_Encode;

   --  ------------------------------
   --  Benchmark test for SHA1
   --  ------------------------------
   procedure Test_SHA1_Benchmark (T : in out Test) is
      pragma Unreferenced (T);

      Hash  : Util.Encoders.SHA1.Digest;
      Sizes : constant array (1 .. 6) of Positive := (1, 10, 100, 1000, 10000, 100000);
   begin
      for I in Sizes'Range loop
         declare
            Size : constant Positive := Sizes (I);
            S    : constant String (1 .. Size) := (others => '0');
            T1   : Util.Measures.Stamp;
            C    : Util.Encoders.SHA1.Context;
         begin
            Util.Encoders.SHA1.Update (C, S);
            Util.Encoders.SHA1.Finish (C, Hash);

            Util.Measures.Report (T1, "Encode SHA1" & Integer'Image (Size) & " bytes");
         end;
      end loop;
   end Test_SHA1_Benchmark;

   procedure Check_HMAC (T      : in out Test'Class;
                         Key    : in String;
                         Value  : in String;
                         Expect : in String) is
      H : constant String := Util.Encoders.HMAC.SHA1.Sign (Key, Value);
   begin
      Assert_Equals (T, Expect, Util.Strings.Transforms.To_Lower_Case (H),
                     "Invalid HMAC-SHA1");
   end Check_HMAC;

   --  ------------------------------
   --  Test HMAC-SHA1
   --  ------------------------------
   procedure Test_HMAC_SHA1_RFC2202_T1 (T : in out Test) is
      Key : constant String (1 .. 20) := (others => Character'Val (16#0b#));
   begin
      Check_HMAC (T, Key, "Hi There", "b617318655057264e28bc0b6fb378c8ef146be00");
   end Test_HMAC_SHA1_RFC2202_T1;

   procedure Test_HMAC_SHA1_RFC2202_T2 (T : in out Test) is
   begin
      Check_HMAC (T, "Jefe", "what do ya want for nothing?",
                  "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79");
   end Test_HMAC_SHA1_RFC2202_T2;

   procedure Test_HMAC_SHA1_RFC2202_T3 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#aa#));
      Data : constant String (1 .. 50) := (others => Character'Val (16#dd#));
   begin
      Check_HMAC (T, Key, Data,
                  "125d7342b9ac11cd91a39af48aa17b4f63f175d3");
   end Test_HMAC_SHA1_RFC2202_T3;

   procedure Test_HMAC_SHA1_RFC2202_T4 (T : in out Test) is
      C    : constant Util.Encoders.Encoder := Create ("hex");
      Key  : constant String := Util.Encoders.Decode (C, "0102030405060708090a0b0c0d0e0f"
                                                      & "10111213141516171819");
      Data : constant String (1 .. 50) := (others => Character'Val (16#cd#));
   begin
      Check_HMAC (T, Key, Data,
                  "4c9007f4026250c6bc8414f9bf50c86c2d7235da");
   end Test_HMAC_SHA1_RFC2202_T4;

   procedure Test_HMAC_SHA1_RFC2202_T5 (T : in out Test) is
      Key  : constant String (1 .. 20) := (others => Character'Val (16#0c#));
   begin
      --  RFC2202 test case 5 but without truncation...
      Check_HMAC (T, Key, "Test With Truncation",
                  "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04");
   end Test_HMAC_SHA1_RFC2202_T5;

   procedure Test_HMAC_SHA1_RFC2202_T6 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key - Hash Key First",
                  "aa4ae5e15272d00e95705637ce8a3b55ed402112");
   end Test_HMAC_SHA1_RFC2202_T6;

   procedure Test_HMAC_SHA1_RFC2202_T7 (T : in out Test) is
      Key  : constant String (1 .. 80) := (others => Character'Val (16#Aa#));
   begin
      Check_HMAC (T, Key, "Test Using Larger Than Block-Size Key and Larger "
                    & "Than One Block-Size Data",
                  "e8e99d0f45237d786d6bbaa7965c7808bbff1a91");
   end Test_HMAC_SHA1_RFC2202_T7;

end Util.Encoders.Tests;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  util-system-os -- Unix system operations
--  Copyright (C) 2011, 2012 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 System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type File_Type is new Integer;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer;
   pragma Import (C, Close, "close");

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T;
   pragma Import (C, Read, "read");

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T;
   pragma Import (C, Write, "write");

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer);
   pragma Import (C, Sys_Exit, "_exit");

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_Fork, "fork");

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_VFork, "fork");

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer;
   pragma Import (C, Sys_Execvp, "execvp");

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer;
   pragma Import (C, Sys_Waitpid, "waitpid");

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer;
   pragma Import (C, Sys_Pipe, "pipe");

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer;
   pragma Import (C, Sys_Dup2, "dup2");

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;
   pragma Import (C, Sys_Close, "close");

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Interfaces.C.int) return File_Type;
   pragma Import (C, Sys_Open, "open");

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer;
   pragma Import (C, Sys_Fcntl, "fcntl");

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer;
   pragma Import (C, Sys_Kill, "kill");

end Util.Systems.Os;

-----------------------------------------------------------------------
--  util-system-os -- Unix system operations
--  Copyright (C) 2011, 2012, 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 System;
with Interfaces.C;
with Interfaces.C.Strings;
with Util.Processes;
with Util.Systems.Constants;
with Util.Systems.Types;

--  The Util.Systems.Os package defines various types and operations which are specific
--  to the OS (Unix).
package Util.Systems.Os is

   --  The directory separator.
   Directory_Separator : constant Character := '/';

   subtype Ptr is Interfaces.C.Strings.chars_ptr;
   subtype Ptr_Array is Interfaces.C.Strings.chars_ptr_array;
   type Ptr_Ptr_Array is access all Ptr_Array;

   type File_Type is new Integer;

   --  Standard file streams Posix, X/Open standard values.
   STDIN_FILENO  : constant File_Type := 0;
   STDOUT_FILENO : constant File_Type := 1;
   STDERR_FILENO : constant File_Type := 2;

   --  File is not opened
   NO_FILE       : constant File_Type := -1;

   --  The following values should be externalized.  They are valid for GNU/Linux.
   F_SETFL    : constant Interfaces.C.int := Util.Systems.Constants.F_SETFL;
   FD_CLOEXEC : constant Interfaces.C.int := Util.Systems.Constants.FD_CLOEXEC;

   --  These values are specific to Linux.
   O_RDONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_RDONLY;
   O_WRONLY   : constant Interfaces.C.int := Util.Systems.Constants.O_WRONLY;
   O_RDWR     : constant Interfaces.C.int := Util.Systems.Constants.O_RDWR;
   O_CREAT    : constant Interfaces.C.int := Util.Systems.Constants.O_CREAT;
   O_EXCL     : constant Interfaces.C.int := Util.Systems.Constants.O_EXCL;
   O_TRUNC    : constant Interfaces.C.int := Util.Systems.Constants.O_TRUNC;
   O_APPEND   : constant Interfaces.C.int := Util.Systems.Constants.O_APPEND;

   type Size_T is mod 2 ** Standard'Address_Size;

   type Ssize_T is range -(2 ** (Standard'Address_Size - 1))
     .. +(2 ** (Standard'Address_Size - 1)) - 1;

   function Close (Fd : in File_Type) return Integer;
   pragma Import (C, Close, "close");

   function Read (Fd   : in File_Type;
                  Buf  : in System.Address;
                  Size : in Size_T) return Ssize_T;
   pragma Import (C, Read, "read");

   function Write (Fd   : in File_Type;
                   Buf  : in System.Address;
                   Size : in Size_T) return Ssize_T;
   pragma Import (C, Write, "write");

   --  System exit without any process cleaning.
   --  (destructors, finalizers, atexit are not called)
   procedure Sys_Exit (Code : in Integer);
   pragma Import (C, Sys_Exit, "_exit");

   --  Fork a new process
   function Sys_Fork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_Fork, "fork");

   --  Fork a new process (vfork implementation)
   function Sys_VFork return Util.Processes.Process_Identifier;
   pragma Import (C, Sys_VFork, "fork");

   --  Execute a process with the given arguments.
   function Sys_Execvp (File : in Ptr;
                        Args : in Ptr_Array) return Integer;
   pragma Import (C, Sys_Execvp, "execvp");

   --  Wait for the process Pid to finish and return
   function Sys_Waitpid (Pid     : in Integer;
                         Status  : in System.Address;
                         Options : in Integer) return Integer;
   pragma Import (C, Sys_Waitpid, "waitpid");

   --  Create a bi-directional pipe
   function Sys_Pipe (Fds : in System.Address) return Integer;
   pragma Import (C, Sys_Pipe, "pipe");

   --  Make fd2 the copy of fd1
   function Sys_Dup2 (Fd1, Fd2 : in File_Type) return Integer;
   pragma Import (C, Sys_Dup2, "dup2");

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer;
   pragma Import (C, Sys_Close, "close");

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Interfaces.C.int) return File_Type;
   pragma Import (C, Sys_Open, "open");

   --  Change the file settings
   function Sys_Fcntl (Fd    : in File_Type;
                       Cmd   : in Interfaces.C.int;
                       Flags : in Interfaces.C.int) return Integer;
   pragma Import (C, Sys_Fcntl, "fcntl");

   function Sys_Kill (Pid : in Integer;
                      Signal : in Integer) return Integer;
   pragma Import (C, Sys_Kill, "kill");

   function Sys_Stat (Path : in Ptr;
                      Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Stat, "stat");

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer;
   pragma Import (C, Sys_Fstat, "fstat");

end Util.Systems.Os;

Define the Sys_Stat and Sys_Fstat operations


-----------------------------------------------------------------------
--  ado-sequences-tests -- Test sequences factories
--  Copyright (C) 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 ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with ADO.Statements;
with Regtests.Simple.Model;

with ADO.Sequences.Hilo;
with ADO.Sessions.Sources;
with ADO.Sessions.Factory;
with ADO.Schemas;
package body ADO.Sequences.Tests is

   type Test_Impl is
     new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                    Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE)
   with record
      Version : Integer;
      Value   : ADO.Identifier;
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Select_Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Destroy (Object : access Test_Impl);

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Sequences.Create",
                       Test_Create_Factory'Access);
   end Add_Tests;

   SEQUENCE_NAME : aliased constant String := "sequence";

   Sequence_Table : aliased ADO.Schemas.Class_Mapping
     := ADO.Schemas.Class_Mapping '(Count => 0, Table => SEQUENCE_NAME'Access, Members => <>);

   --  Test creation of the sequence factory.
   --  This test revealed a memory leak if we failed to create a database connection.
   procedure Test_Create_Factory (T : in out Test) is
      Seq_Factory : ADO.Sequences.Factory;
      Obj         : Test_Impl;
      Factory     : aliased ADO.Sessions.Factory.Session_Factory;
      Controller  : aliased ADO.Sessions.Sources.Data_Source;
      Prev_Id     : Identifier := ADO.NO_IDENTIFIER;
   begin
      Seq_Factory.Set_Default_Generator (ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                                         Factory'Unchecked_Access);
      begin
         Seq_Factory.Allocate (Obj);
         T.Assert (False, "No exception raised.");

      exception
         when ADO.Sessions.Connection_Error =>
            null;  --  Good! An exception is expected because the session factory is empty.
      end;

      --  Make a real connection.
      Controller.Set_Connection (ADO.Drivers.Get_Config ("test.database"));
      Factory.Create (Controller);
      for I in 1 .. 1_000 loop
         Seq_Factory.Allocate (Obj);
         T.Assert (Obj.Get_Key_Value /= Prev_Id, "Invalid id was allocated");
         Prev_Id := Obj.Get_Key_Value;
      end loop;

      --  Erase the sequence entry used for the allocate entity table.
      declare
         S : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         D : ADO.Statements.Delete_Statement := S.Create_Statement (Sequence_Table'Access);
      begin
         D.Set_Filter ("name = :name");
         D.Bind_Param ("name", String '("allocate"));
         D.Execute;

         --  Also delete all allocate items.
         D := S.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
         D.Execute;
      end;

      --  Create new objects.  This forces the creation of a new entry in the sequence table.
      for I in 1 .. 1_00 loop
         Seq_Factory.Allocate (Obj);
         T.Assert (Obj.Get_Key_Value /= Prev_Id, "Invalid id was allocated");
         Prev_Id := Obj.Get_Key_Value;
      end loop;
   end Test_Create_Factory;

   overriding
   procedure Destroy (Object : access Test_Impl) is
   begin
      null;
   end Destroy;

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean) is
      pragma Unreferenced (Object, Session, Query);
   begin
      Found := False;
   end Find;

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class) is
   begin
      null;
   end Load;

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Save;

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Delete;

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Create;

end ADO.Sequences.Tests;

-----------------------------------------------------------------------
--  ado-sequences-tests -- Test sequences factories
--  Copyright (C) 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 ADO.Drivers;
with ADO.Sessions;
with ADO.SQL;
with ADO.Statements;
with Regtests.Simple.Model;

with ADO.Sequences.Hilo;
with ADO.Sessions.Sources;
with ADO.Sessions.Factory;
with ADO.Schemas;
package body ADO.Sequences.Tests is

   type Test_Impl is
     new ADO.Objects.Object_Record (Key_Type => ADO.Objects.KEY_INTEGER,
                                    Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE)
   with record
      Version : Integer;
      Value   : ADO.Identifier;
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Select_Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   overriding
   procedure Destroy (Object : access Test_Impl);

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean);

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class);

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class);

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Sequences.Create",
                       Test_Create_Factory'Access);
   end Add_Tests;

   SEQUENCE_NAME : aliased constant String := "sequence";

   Sequence_Table : aliased ADO.Schemas.Class_Mapping
     := ADO.Schemas.Class_Mapping '(Count => 0, Table => SEQUENCE_NAME'Access, Members => <>);

   --  Test creation of the sequence factory.
   --  This test revealed a memory leak if we failed to create a database connection.
   procedure Test_Create_Factory (T : in out Test) is
      Seq_Factory : ADO.Sequences.Factory;
      Obj         : Test_Impl;
      Factory     : aliased ADO.Sessions.Factory.Session_Factory;
      Controller  : aliased ADO.Sessions.Sources.Data_Source;
      Prev_Id     : Identifier := ADO.NO_IDENTIFIER;
   begin
      Seq_Factory.Set_Default_Generator (ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                                         Factory'Unchecked_Access);
      begin
         Seq_Factory.Allocate (Obj);
         T.Assert (False, "No exception raised.");

      exception
         when ADO.Sessions.Connection_Error =>
            null;  --  Good! An exception is expected because the session factory is empty.
      end;

      --  Make a real connection.
      Controller.Set_Connection (ADO.Drivers.Get_Config ("test.database"));
      Factory.Create (Controller);
      for I in 1 .. 1_000 loop
         Seq_Factory.Allocate (Obj);
         T.Assert (Obj.Get_Key_Value /= Prev_Id, "Invalid id was allocated");
         Prev_Id := Obj.Get_Key_Value;
      end loop;

      --  Erase the sequence entry used for the allocate entity table.
      declare
         S : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
         D : ADO.Statements.Delete_Statement := S.Create_Statement (Sequence_Table'Access);
      begin
         D.Set_Filter ("name = :name");
         D.Bind_Param ("name", String '("allocate"));
         D.Execute;

         --  Also delete all allocate items.
         D := S.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE);
         D.Execute;
      end;

      --  Create new objects.  This forces the creation of a new entry in the sequence table.
      for I in 1 .. 1_00 loop
         Seq_Factory.Allocate (Obj);
         T.Assert (Obj.Get_Key_Value /= Prev_Id, "Invalid id was allocated");
         Prev_Id := Obj.Get_Key_Value;
      end loop;
   end Test_Create_Factory;

   overriding
   procedure Destroy (Object : access Test_Impl) is
   begin
      null;
   end Destroy;

   overriding
   procedure Find (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.SQL.Query'Class;
                   Found   : out Boolean) is
      pragma Unreferenced (Object, Session, Query);
   begin
      Found := False;
   end Find;

   overriding
   procedure Load (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Session'Class) is
   begin
      null;
   end Load;

   overriding
   procedure Save (Object  : in out Test_Impl;
                   Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Save;

   overriding
   procedure Delete (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Delete;

   overriding
   procedure Create (Object  : in out Test_Impl;
                     Session : in out ADO.Sessions.Master_Session'Class) is
   begin
      null;
   end Create;

end ADO.Sequences.Tests;

Fix compilation warning

Fix compilation warning