------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--     A S I S . A D A _ E N V I R O N M E N T S . C O N T A I N E R S      --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2006, Free Software Foundation, Inc.       --
--                                                                          --
-- This   specification  is  derived   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  The copyright --
-- notice above, and the license provisions that follow apply solely to the --
-- contents of the part following the private keyword.                      --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  9  package Asis.Ada_Environments.Containers
------------------------------------------------------------------------------

------------------------------------------------------------------------------
package Asis.Ada_Environments.Containers is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Ada_Environments.Containers
--
--  If an Ada implementation supports the notion of a program library or
--  "library" as specified in Subclause 10(2) of the Ada Reference Manual,
--  then an ASIS Context value can be mapped onto one or more implementor
--  libraries represented by Containers.
--
------------------------------------------------------------------------------
--  9.1   type Container
------------------------------------------------------------------------------
--
--  The Container abstraction is a logical collection of compilation units.
--  For example, one container might hold compilation units which include Ada
--  predefined library units, another container might hold
--  implementation-defined packages. Alternatively, there might be 26
--  containers, each holding compilation units that begin with their respective
--  letter of the alphabet. The point is that no implementation-independent
--  semantics are associated with a container; it is simply a logical
--  collection.
--
--  ASIS implementations shall minimally map the Asis.Context to a list of
--  one ASIS Container whose Name is that of the Asis.Context Name.
------------------------------------------------------------------------------

   type Container is private;
   Nil_Container : constant Container;

   function "="
     (Left  : Container;
      Right : Container)
     return   Boolean is abstract;

------------------------------------------------------------------------------
--  9.2   type Container_List
------------------------------------------------------------------------------

   type Container_List is array (List_Index range <>) of Container;

------------------------------------------------------------------------------
--  9.3   function Defining_Containers
------------------------------------------------------------------------------

   function Defining_Containers
     (The_Context : Asis.Context)
      return        Container_List;

------------------------------------------------------------------------------
--  The_Context - Specifies the Context to define
--
--  Returns a Container_List value that defines the single environment Context.
--  Each Container will have an Enclosing_Context that Is_Identical to the
--  argument The_Context.  The order of Container values in the list is not
--  defined.
--
--  Returns a minimal list of length one if the ASIS Ada implementation does
--  not support the concept of a program library.  In this case, the Container
--  will have the same name as the given Context.
--
--  Raises ASIS_Inappropriate_Context if The_Context is not open.
--

------------------------------------------------------------------------------
--  9.4   function Enclosing_Context
------------------------------------------------------------------------------

   function Enclosing_Context
     (The_Container : Container)
      return          Asis.Context;

------------------------------------------------------------------------------
--  The_Container - Specifies the Container to query
--
--  Returns the Context value associated with the Container.
--
--  Returns the Context for which the Container value was originally obtained.
--  Container values obtained through the Defining_Containers query will always
--  remember the Context from which they were defined.
--
--  Because Context is limited private, this function is only intended to be
--  used to supply a Context parameter for other queries.
--
--  Raises ASIS_Inappropriate_Container if the Container is a Nil_Container.
--
------------------------------------------------------------------------------
--  9.5   function Library_Unit_Declaration
------------------------------------------------------------------------------

   function Library_Unit_Declarations
     (The_Container : Container)
      return          Asis.Compilation_Unit_List;

------------------------------------------------------------------------------
--  The_Container - Specifies the Container to query
--
--  Returns a list of all library_unit_declaration and
--  library_unit_renaming_declaration  elements contained in the Container.
--  Individual units will appear only once in an order that is not defined.
--
--  A Nil_Compilation_Unit_List is returned if there are no declarations of
--  library units within the Container.
--
--  This query will never return a unit with A_Configuration_Compilation or
--  a Nonexistent unit kind. It will never return a unit with A_Procedure_Body
--  or A_Function_Body unit kind even though the unit is interpreted as both
--  the declaration and body of a library procedure or library function.
--  (Reference Manual 10.1.4(4).
--
--  All units in the result will have an Enclosing_Container value that
--  Is_Identical to the Container.
--
--  Raises ASIS_Inappropriate_Context if the Enclosing_Context(Container)
--  is not open.
--

------------------------------------------------------------------------------
--  9.6   function Compilation_Unit_Bodies
------------------------------------------------------------------------------

   function Compilation_Unit_Bodies
     (The_Container : Container)
      return          Asis.Compilation_Unit_List;

------------------------------------------------------------------------------
--  The_Container - Specifies the Container to query
--
--  Returns a list of all library_unit_body and subunit elements contained in
--  the Container. Individual units will appear only once in an order that is
--  not defined.
--
--  A Nil_Compilation_Unit_List is returned if there are no bodies within the
--  Container.
--
--  This query will never return a unit with A_Configuration_Compilation or
--  a nonexistent unit kind.
--
--  All units in the result will have an Enclosing_Container value that
--  Is_Identical to the Container.
--
--  Raises ASIS_Inappropriate_Context if the Enclosing_Context(Container)
--  is not open.
--
------------------------------------------------------------------------------
--  9.7   function Compilation_Units
------------------------------------------------------------------------------

   function Compilation_Units
     (The_Container : Container)
      return          Asis.Compilation_Unit_List;

------------------------------------------------------------------------------
--  The_Container - Specifies the Container to query
--
--  Returns a list of all compilation units contained in the Container.
--  Individual units will appear only once in an order that is not defined.
--
--  A Nil_Compilation_Unit_List is returned if there are no units within the
--  Container.
--
--  This query will never return a unit with A_Configuration_Compilation or
--  a nonexistent unit kind.
--
--  All units in the result will have an Enclosing_Container value that
--  Is_Identical to the Container.
--
--  Raises ASIS_Inappropriate_Context if the Enclosing_Context(Container)
--  is not open.
--
------------------------------------------------------------------------------
--  9.8   function Is_Equal
------------------------------------------------------------------------------

   function Is_Equal
     (Left  : Container;
      Right : Container)
      return  Boolean;

------------------------------------------------------------------------------
--  Left    - Specifies the first Container
--  Right   - Specifies the second Container
--
--  Returns True if Left and Right designate Container values that contain the
--  same set of compilation units.  The Container values may have been defined
--  from different Context values.
--

------------------------------------------------------------------------------
--  9.9   function Is_Identical
------------------------------------------------------------------------------

   function Is_Identical
     (Left  : Container;
      Right : Container)
      return  Boolean;

------------------------------------------------------------------------------
--  Left    - Specifies the first Container
--  Right   - Specifies the second Container
--
--  Returns True if Is_Equal(Left, Right) and the Container values have been
--  defined from Is_Equal Context values.
--
------------------------------------------------------------------------------
--  9.10  function Name
------------------------------------------------------------------------------

   function Name (The_Container : Container) return Wide_String;

------------------------------------------------------------------------------
--  The_Container - Specifies the Container to name
--
--  Returns the Name value associated with the Container.
--
--  Returns a null string if the Container is a Nil_Container.

private

   type Container is record
      Id       : Container_Id := Nil_Container_Id;
      Cont_Id  : Context_Id   := Non_Associated;
      Obtained : ASIS_OS_Time := Nil_ASIS_OS_Time;
   end record;

   Nil_Container : constant Container :=
     (Id       => Nil_Container_Id,
      Cont_Id  => Non_Associated,
      Obtained => Nil_ASIS_OS_Time);

end Asis.Ada_Environments.Containers;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  mat -- Memory Analysis Tool
--  Copyright (C) 2014, 2021 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log.Loggers;
with Util.Properties;
package body MAT is

   --  ------------------------------
   --  Configure the logs.
   --  ------------------------------
   procedure Configure_Logs (Debug   : in Boolean;
                             Dump    : in Boolean;
                             Verbose : in Boolean) is
      Log_Config  : Util.Properties.Manager;
   begin
      Log_Config.Set ("log4j.rootCategory", "ERROR,errorConsole");
      Log_Config.Set ("log4j.appender.errorConsole", "aktConsole");
      Log_Config.Set ("log4j.appender.errorConsole.level", "ERROR");
      Log_Config.Set ("log4j.appender.errorConsole.layout", "message");
      Log_Config.Set ("log4j.appender.errorConsole.stderr", "true");
      Log_Config.Set ("log4j.logger.Util", "FATAL");
      Log_Config.Set ("log4j.logger.Util.Events", "ERROR");
      Log_Config.Set ("log4j.logger.Keystore", "ERROR");
      Log_Config.Set ("log4j.logger.AKT", "ERROR");
      if Verbose or Debug or Dump then
         Log_Config.Set ("log4j.logger.Util", "WARN");
         Log_Config.Set ("log4j.logger.AKT", "INFO");
         Log_Config.Set ("log4j.logger.Keystore.IO", "WARN");
         Log_Config.Set ("log4j.logger.Keystore", "INFO");
         Log_Config.Set ("log4j.rootCategory", "INFO,errorConsole,verbose");
         Log_Config.Set ("log4j.appender.verbose", "Console");
         Log_Config.Set ("log4j.appender.verbose.level", "INFO");
         Log_Config.Set ("log4j.appender.verbose.layout", "level-message");
      end if;
      if Debug or Dump then
         Log_Config.Set ("log4j.logger.Util.Processes", "INFO");
         Log_Config.Set ("log4j.logger.AKT", "DEBUG");
         Log_Config.Set ("log4j.logger.Keystore.IO", "INFO");
         Log_Config.Set ("log4j.logger.Keystore", "DEBUG");
         Log_Config.Set ("log4j.rootCategory", "DEBUG,errorConsole,debug");
         Log_Config.Set ("log4j.appender.debug", "Console");
         Log_Config.Set ("log4j.appender.debug.level", "DEBUG");
         Log_Config.Set ("log4j.appender.debug.layout", "full");
      end if;
      if Dump then
         Log_Config.Set ("log4j.logger.Keystore.IO", "DEBUG");
      end if;

      Util.Log.Loggers.Initialize (Log_Config);

   end Configure_Logs;

end MAT;

Implement Configure_Logs procedure

Implement Configure_Logs procedure


-----------------------------------------------------------------------
--  Faces Context Tests - Unit tests for ASF.Contexts.Faces
--  Copyright (C) 2010, 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.Calendar;
with Ada.Calendar.Formatting;
with Util.Beans.Objects.Time;
with Util.Test_Caller;
with ASF.Tests;
with ASF.Components.Html.Text;
with ASF.Converters.Dates;
package body ASF.Converters.Tests is

   use Util.Tests;
   use ASF.Converters.Dates;

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

   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Short)",
                       Test_Date_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Medium)",
                       Test_Date_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Long)",
                       Test_Date_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Full)",
                       Test_Date_Full_Converter'Access);

      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Short)",
                       Test_Time_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Medium)",
                       Test_Time_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Long)",
                       Test_Time_Long_Converter'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String) is
      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
      D     : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19,
                                                                             3, 4, 5);
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      if Date_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.TIME,
                                                          Locale  => "en",
                                                          Pattern => "");
      elsif Time_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.DATE,
                                                          Locale  => "en",
                                                          Pattern => "");
      else
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.BOTH,
                                                          Locale  => "en",
                                                          Pattern => "");
      end if;
      UI.Set_Converter (C.all'Access);
      declare
         R : constant String := C.To_String (Ctx, UI, Util.Beans.Objects.Time.To_Object (D));
      begin
         Util.Tests.Assert_Equals (T, Expect, R, "Invalid date conversion");
      end;
   end Test_Date_Conversion;

   --  ------------------------------
   --  Test the date short converter.
   --  ------------------------------
   procedure Test_Date_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.SHORT, ASF.Converters.Dates.DEFAULT,
                            "19/11/2011");
   end Test_Date_Short_Converter;

   --  ------------------------------
   --  Test the date medium converter.
   --  ------------------------------
   procedure Test_Date_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.MEDIUM, ASF.Converters.Dates.DEFAULT,
                            "Nov 19, 2011");
   end Test_Date_Medium_Converter;

   --  ------------------------------
   --  Test the date long converter.
   --  ------------------------------
   procedure Test_Date_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.LONG, ASF.Converters.Dates.DEFAULT,
                            "November 19, 2011");
   end Test_Date_Long_Converter;

   --  ------------------------------
   --  Test the date full converter.
   --  ------------------------------
   procedure Test_Date_Full_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.FULL, ASF.Converters.Dates.DEFAULT,
                            "Saturday, November 19, 2011");
   end Test_Date_Full_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.SHORT,
                            "03:04");
   end Test_Time_Short_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.MEDIUM,
                            "03:04");
   end Test_Time_Medium_Converter;

   --  ------------------------------
   --  Test the time long converter.
   --  ------------------------------
   procedure Test_Time_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.LONG,
                            "03:04:05");
   end Test_Time_Long_Converter;

end ASF.Converters.Tests;

Implement some unit tests for date and time conversion


-----------------------------------------------------------------------
--  util-beans-objects-datasets-tests -- Unit tests for dataset beans
--  Copyright (C) 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 Util.Tests;
with Util.Test_Caller;

package body Util.Beans.Objects.Datasets.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Beans.Objects.Datasets",
                       Test_Fill_Dataset'Access);
   end Add_Tests;

   --  Test the creation, initialization and retrieval of dataset content.
   procedure Test_Fill_Dataset (T : in out Test) is
      Set : Dataset;

      procedure Fill (Row : in out Object_Array) is
      begin
         Row (Row'First)     := To_Object (String '("john"));
         Row (Row'First + 1) := To_Object (String '("jj@gmail.com"));
         Row (Row'First + 2) := To_Object (Set.Get_Count);
      end Fill;

   begin
      Set.Add_Column ("name");
      Set.Add_Column ("email");
      Set.Add_Column ("age");

      for I in 1 .. 100 loop
         Set.Append (Fill'Access);
      end loop;
      Util.Tests.Assert_Equals (T, 100, Set.Get_Count, "Invalid number of rows");

      for I in 1 .. 100 loop
         Set.Set_Row_Index (I);
         declare
            R : Object := Set.Get_Row;

         begin
            T.Assert (not Is_Null (R), "Row is null");
            Util.Tests.Assert_Equals (T, "john", To_String (Get_Value (R, "name")),
                                      "Invalid 'name' attribute");
            Util.Tests.Assert_Equals (T, I, To_Integer (Get_Value (R, "age")),
                                      "Invalid 'age' attribute");
         end;
      end loop;
   end Test_Fill_Dataset;

end Util.Beans.Objects.Datasets.Tests;

Implement the unit tests on datasets to verify the creation, insertion and retrieval of datasets through bean interfaces


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--      A S I S . C O M P I L A T I O N _ U N I T S . R E L A T I O N S     --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-2006, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Errors;     use Asis.Errors;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Extensions; use Asis.Extensions;

with Asis.Set_Get;    use  Asis.Set_Get;

with A4G.Contt.Dp;    use A4G.Contt.Dp;
with A4G.Vcheck;      use A4G.Vcheck;

package body Asis.Compilation_Units.Relations is

   Package_Name : constant String := "Asis.Compilation_Units.Relations.";

   -----------------------
   -- Elaboration_Order --
   -----------------------
   --  NOT  IMPLEMENTED --

   function Elaboration_Order
     (Compilation_Units : Asis.Compilation_Unit_List;
      The_Context       : Asis.Context)
      return              Relationship
   is
   begin

      Check_Validity (The_Context,
               Package_Name & "Semantic_Dependence_Order");

      if Is_Nil (Compilation_Units) then
         return Nil_Relationship;
      end if;

      Not_Implemented_Yet (Diagnosis =>
                Package_Name & "Semantic_Dependence_Order");
      --  ASIS_Failed is raised, Not_Implemented_Error status is setted

      return Nil_Relationship; -- to make the code syntactically correct

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Semantic_Dependence_Order");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Semantic_Dependence_Order",
            Ex         => Ex);
   end Elaboration_Order;

   -------------------------------
   -- Semantic_Dependence_Order --
   -------------------------------
   --   PARTIALLY IMPLEMENTED   --

   function Semantic_Dependence_Order
     (Compilation_Units : Asis.Compilation_Unit_List;
      Dependent_Units   : Asis.Compilation_Unit_List;
      The_Context       : Asis.Context;
      Relation          : Asis.Relation_Kinds)
      return              Relationship
   is
      Res_Cont_Id  : Context_Id;
      Arg_Kind     : Asis.Unit_Kinds;
      Result_List  : Compilation_Unit_List_Access;
      Missing_List : Compilation_Unit_List_Access;
      Missing_Len  : ASIS_Natural := 0;
   begin
      Check_Validity (The_Context, Package_Name & "Semantic_Dependence_Order");

      Res_Cont_Id := Get_Cont_Id (The_Context);
      --  The current implementation limitation is that all the units from
      --  Compilation_Units list and from Dependent_Units should be from
      --  The_Context

      for I in Compilation_Units'Range loop
         Check_Validity (Compilation_Units (I),
                         Package_Name & "Semantic_Dependence_Order");

         Arg_Kind := Kind (Compilation_Units (I));

         if Arg_Kind = Not_A_Unit                or else
            Arg_Kind = A_Nonexistent_Declaration or else
            Arg_Kind = A_Nonexistent_Body        or else
            Arg_Kind = A_Configuration_Compilation
         then
            Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
               Package_Name & "Semantic_Dependence_Order");
         end if;

         if Res_Cont_Id /= Encl_Cont_Id (Compilation_Units (I)) then
            Not_Implemented_Yet (Diagnosis =>
               Package_Name &
               "Semantic_Dependence_Order (multi-context processing");
         end if;

      end loop;

      for I in Dependent_Units'Range loop
         Check_Validity (Dependent_Units (I),
                         Package_Name & "Semantic_Dependence_Order");

         Arg_Kind := Kind (Dependent_Units (I));

         if Arg_Kind = Not_A_Unit                or else
            Arg_Kind = A_Nonexistent_Declaration or else
            Arg_Kind = A_Nonexistent_Body        or else
            Arg_Kind = A_Configuration_Compilation
         then
            Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
               Package_Name & "Semantic_Dependence_Order");
         end if;

         if Res_Cont_Id /= Encl_Cont_Id (Dependent_Units (I)) then
            Not_Implemented_Yet (Diagnosis =>
               Package_Name &
               "Semantic_Dependence_Order (multi-context processing");
         end if;

      end loop;

      if Is_Nil (Compilation_Units) then
         return Nil_Relationship;
      end if;

      case Relation is
         when Ancestors =>

            Set_All_Ancestors (Compilation_Units, Result_List);

         when Descendants =>

            Set_All_Descendants (Compilation_Units, Result_List);

         when Supporters =>

            Set_All_Supporters (Compilation_Units, Result_List);

         when Dependents =>

            Set_All_Dependents
              (Compilation_Units, Dependent_Units, Result_List);

         when Family =>

            Set_All_Families (Compilation_Units, Result_List);

         when Needed_Units =>

            Set_All_Needed_Units
              (Compilation_Units, Result_List, Missing_List);

      end case;

      if Missing_List /= null then
         Missing_Len := Missing_List'Length;
      end if;

      declare
         Result : Relationship
                    (Consistent_Length   => Result_List'Length,
                     Inconsistent_Length => 0,
                     Missing_Length      => Missing_Len,
                     Circular_Length     => 0);
      begin
         Result.Consistent := Result_List.all;

         if Missing_List /= null then
            Result.Missing := Missing_List.all;
         end if;

         Free (Result_List);
         Free (Missing_List);

         return Result;
      end;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Semantic_Dependence_Order");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Semantic_Dependence_Order",
            Ex         => Ex);
   end Semantic_Dependence_Order;

end Asis.Compilation_Units.Relations;

Add the ASIS file $i

Add the ASIS file $i


--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Latin_1;

with Ahven.Runner;
with Ahven.XML_Runner;
with Ahven.AStrings;

use Ada.Text_IO;
use Ada.Strings.Fixed;

package body Ahven.Text_Runner is
   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   -- Local procedures
   procedure Pad (Level : Natural);

   procedure Print_Test (Info   : Result_Info;
                         Level  : Natural;
                         Result : String);

   procedure Print_Passes (Result : Result_Collection;
                           Level  : Natural);

   procedure Report_Results (Result  : Result_Collection;
                             Verbose : Boolean := False);

   procedure Print_Log_File (Filename : String);

   procedure Pad (Level : Natural) is
   begin
      for A in Integer range 1 .. Level loop
         Put (" ");
      end loop;
   end Pad;

   procedure Pad (Amount : in     Natural;
                  Total  : in out Natural) is
   begin
      for A in Natural range 1 .. Amount loop
         Put (" ");
      end loop;
      Total := Total + Amount;
   end Pad;

   procedure Multiline_Pad (Input  : String;
                            Level  : Natural) is
   begin
      Pad (Level);
      for A in Input'Range loop
         Put (Input (A));
         if (Input (A) = Ada.Characters.Latin_1.LF) and (A /= Input'Last) then
            Pad (Level);
         end if;
      end loop;
   end Multiline_Pad;

   procedure Print_Test (Info   : Result_Info;
                         Level  : Natural;
                         Result : String) is
      use Ada.Strings;

      Max_Output_Width : constant := 50;
      Max_Result_Width : constant := 7;
      Max_Time_Out_Width : constant := 12;

      subtype Result_Size is Integer range 1 .. Max_Result_Width;
      subtype Time_Out_Size is Integer range 1 .. Max_Time_Out_Width;

      procedure Print_Text (Str : String; Total : in out Natural) is
      begin
         Put (Str);
         Total := Total + Str'Length;
      end Print_Text;

      Msg        : constant String := Get_Message (Info);
      Result_Out : String (Result_Size) := (others => ' ');
      Time_Out   : String (Time_Out_Size) := (others => ' ');
      Total_Text : Natural := 0;

   begin
      Pad (Level + 1, Total_Text);
      Print_Text (Get_Routine_Name (Info), Total_Text);
      if Msg'Length > 0 then
         Print_Text (" - ", Total_Text);
         Print_Text (Msg, Total_Text);
      end if;

      if Total_Text < Max_Output_Width then
         Pad (Max_Output_Width - Total_Text, Total_Text);
      end if;

      -- If we know the name of the routine, we print it,
      -- the result, and the execution time.
      if Get_Routine_Name (Info)'Length > 0 then
         Move (Source  => Result,
               Target  => Result_Out,
               Drop    => Right,
               Justify => Left,
               Pad     => ' ');
         Move (Source  => Duration'Image (Get_Execution_Time (Info)),
               Target  => Time_Out,
               Drop    => Right,
               Justify => Right,
               Pad     => ' ');
         Put (" " & Result_Out);
         Put (" " & Time_Out & "s");
      end if;
      if Get_Long_Message (Info)'Length > 0 then
         New_Line;
         Multiline_Pad (Get_Long_Message (Info), Level + 2);
      end if;

      New_Line;
   end Print_Test;

   type Print_Child_Proc is access
     procedure (Result : Result_Collection; Level : Natural);

   type Child_Count_Proc is access
     function (Result : Result_Collection) return Natural;

   procedure Print_Children (Result : Result_Collection;
                             Level  : Natural;
                             Action : Print_Child_Proc;
                             Count  : Child_Count_Proc)
   is
      Child_Iter : Result_Collection_Cursor := First_Child (Result);
   begin
      loop
         exit when not Is_Valid (Child_Iter);
         if Count.all (Data (Child_Iter).all) > 0 then
            Action.all (Data (Child_Iter).all, Level + 1);
         end if;
         Child_Iter := Next (Child_Iter);
      end loop;
   end Print_Children;

   procedure Print_Statuses (Result    : Result_Collection;
                             Level     : Natural;
                             Start     : Result_Info_Cursor;
                             Action    : Print_Child_Proc;
                             Status    : String;
                             Count     : Child_Count_Proc;
                             Print_Log : Boolean) is
      Position : Result_Info_Cursor := Start;
   begin
      if Length (Get_Test_Name (Result)) > 0 then
         Pad (Level);
         Put_Line (To_String (Get_Test_Name (Result)) & ":");
      end if;

      Test_Loop :
      loop
         exit Test_Loop when not Is_Valid (Position);
         Print_Test (Data (Position), Level, Status);
         if Print_Log and
           (Length (Get_Output_File (Data (Position))) > 0) then
            Print_Log_File (To_String (Get_Output_File (Data (Position))));
         end if;
         Position := Next (Position);
      end loop Test_Loop;

      Print_Children (Result => Result,
                      Level  => Level,
                      Action => Action,
                      Count  => Count);
   end Print_Statuses;

   --
   -- Print all failures from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Failures (Result : Result_Collection;
                             Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Failure (Result),
         Action    => Print_Failures'Access,
         Status    => "FAIL",
         Count     => Failure_Count'Access,
         Print_Log => True);
   end Print_Failures;

   --
   -- Print all skips from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Skips (Result : Result_Collection;
                          Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Skipped (Result),
         Action    => Print_Skips'Access,
         Status    => "SKIPPED",
         Count     => Skipped_Count'Access,
         Print_Log => True);
   end Print_Skips;

   --
   -- Print all errors from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Errors (Result : Result_Collection;
                           Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Error (Result),
         Action    => Print_Errors'Access,
         Status    => "ERROR",
         Count     => Error_Count'Access,
         Print_Log => True);
   end Print_Errors;

   --
   -- Print all passes from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Passes (Result : Result_Collection;
                           Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Pass (Result),
         Action    => Print_Passes'Access,
         Status    => "PASS",
         Count     => Pass_Count'Access,
         Print_Log => False);
   end Print_Passes;

   --
   -- Report passes, skips, failures, and errors from the result collection.
   procedure Report_Results (Result  : Result_Collection;
                             Verbose : Boolean := False) is
   begin
      Put_Line ("Passed : " & Integer'Image (Pass_Count (Result)));
      if Verbose then
         Print_Passes (Result, 0);
      end if;
      New_Line;
      if Skipped_Count (Result) > 0 then
         Put_Line ("Skipped : " & Integer'Image (Skipped_Count (Result)));
         Print_Skips (Result, 0);
         New_Line;
      end if;
      if Failure_Count (Result) > 0 then
         Put_Line ("Failed : " & Integer'Image (Failure_Count (Result)));
         Print_Failures (Result, 0);
         New_Line;
      end if;
      if Error_Count (Result) > 0 then
         Put_Line ("Errors : " & Integer'Image (Error_Count (Result)));
         Print_Errors (Result, 0);
      end if;
   end Report_Results;

   procedure Print_Log_File (Filename : String) is
      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put_Line ("===== Output =======");
            First := False;
         end if;
         Put (Char);
         if End_Of_Line (Handle) then
            New_Line;
         end if;
      end loop;
      Close (Handle);
      if not First then
         Put_Line ("====================");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      if Parameters.XML_Results (Args) then
         XML_Runner.Report_Results
           (Test_Results, Parameters.Result_Dir (Args));
      else
         Report_Results (Test_Results, Parameters.Verbose (Args));
      end if;
   end Do_Report;

   procedure Run (Suite : in out Framework.Test'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.Text_Runner;

--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Latin_1;
with Ada.IO_Exceptions;

with Ahven.Runner;
with Ahven.XML_Runner;
with Ahven.AStrings;

use Ada.Text_IO;
use Ada.Strings.Fixed;

package body Ahven.Text_Runner is
   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   -- Local procedures
   procedure Pad (Level : Natural);

   procedure Print_Test (Info   : Result_Info;
                         Level  : Natural;
                         Result : String);

   procedure Print_Passes (Result : Result_Collection;
                           Level  : Natural);

   procedure Report_Results (Result  : Result_Collection;
                             Verbose : Boolean := False);

   procedure Print_Log_File (Filename : String);

   procedure Pad (Level : Natural) is
   begin
      for A in Integer range 1 .. Level loop
         Put (" ");
      end loop;
   end Pad;

   procedure Pad (Amount : in     Natural;
                  Total  : in out Natural) is
   begin
      for A in Natural range 1 .. Amount loop
         Put (" ");
      end loop;
      Total := Total + Amount;
   end Pad;

   procedure Multiline_Pad (Input  : String;
                            Level  : Natural) is
   begin
      Pad (Level);
      for A in Input'Range loop
         Put (Input (A));
         if (Input (A) = Ada.Characters.Latin_1.LF) and (A /= Input'Last) then
            Pad (Level);
         end if;
      end loop;
   end Multiline_Pad;

   procedure Print_Test (Info   : Result_Info;
                         Level  : Natural;
                         Result : String) is
      use Ada.Strings;

      Max_Output_Width : constant := 50;
      Max_Result_Width : constant := 7;
      Max_Time_Out_Width : constant := 12;

      subtype Result_Size is Integer range 1 .. Max_Result_Width;
      subtype Time_Out_Size is Integer range 1 .. Max_Time_Out_Width;

      procedure Print_Text (Str : String; Total : in out Natural) is
      begin
         Put (Str);
         Total := Total + Str'Length;
      end Print_Text;

      Msg        : constant String := Get_Message (Info);
      Result_Out : String (Result_Size) := (others => ' ');
      Time_Out   : String (Time_Out_Size) := (others => ' ');
      Total_Text : Natural := 0;

   begin
      Pad (Level + 1, Total_Text);
      Print_Text (Get_Routine_Name (Info), Total_Text);
      if Msg'Length > 0 then
         Print_Text (" - ", Total_Text);
         Print_Text (Msg, Total_Text);
      end if;

      if Total_Text < Max_Output_Width then
         Pad (Max_Output_Width - Total_Text, Total_Text);
      end if;

      -- If we know the name of the routine, we print it,
      -- the result, and the execution time.
      if Get_Routine_Name (Info)'Length > 0 then
         Move (Source  => Result,
               Target  => Result_Out,
               Drop    => Right,
               Justify => Left,
               Pad     => ' ');
         Move (Source  => Duration'Image (Get_Execution_Time (Info)),
               Target  => Time_Out,
               Drop    => Right,
               Justify => Right,
               Pad     => ' ');
         Put (" " & Result_Out);
         Put (" " & Time_Out & "s");
      end if;
      if Get_Long_Message (Info)'Length > 0 then
         New_Line;
         Multiline_Pad (Get_Long_Message (Info), Level + 2);
      end if;

      New_Line;
   end Print_Test;

   type Print_Child_Proc is access
     procedure (Result : Result_Collection; Level : Natural);

   type Child_Count_Proc is access
     function (Result : Result_Collection) return Natural;

   procedure Print_Children (Result : Result_Collection;
                             Level  : Natural;
                             Action : Print_Child_Proc;
                             Count  : Child_Count_Proc)
   is
      Child_Iter : Result_Collection_Cursor := First_Child (Result);
   begin
      loop
         exit when not Is_Valid (Child_Iter);
         if Count.all (Data (Child_Iter).all) > 0 then
            Action.all (Data (Child_Iter).all, Level + 1);
         end if;
         Child_Iter := Next (Child_Iter);
      end loop;
   end Print_Children;

   procedure Print_Statuses (Result    : Result_Collection;
                             Level     : Natural;
                             Start     : Result_Info_Cursor;
                             Action    : Print_Child_Proc;
                             Status    : String;
                             Count     : Child_Count_Proc;
                             Print_Log : Boolean) is
      Position : Result_Info_Cursor := Start;
   begin
      if Length (Get_Test_Name (Result)) > 0 then
         Pad (Level);
         Put_Line (To_String (Get_Test_Name (Result)) & ":");
      end if;

      Test_Loop :
      loop
         exit Test_Loop when not Is_Valid (Position);
         Print_Test (Data (Position), Level, Status);
         if Print_Log and
           (Length (Get_Output_File (Data (Position))) > 0) then
            Print_Log_File (To_String (Get_Output_File (Data (Position))));
         end if;
         Position := Next (Position);
      end loop Test_Loop;

      Print_Children (Result => Result,
                      Level  => Level,
                      Action => Action,
                      Count  => Count);
   end Print_Statuses;

   --
   -- Print all failures from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Failures (Result : Result_Collection;
                             Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Failure (Result),
         Action    => Print_Failures'Access,
         Status    => "FAIL",
         Count     => Failure_Count'Access,
         Print_Log => True);
   end Print_Failures;

   --
   -- Print all skips from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Skips (Result : Result_Collection;
                          Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Skipped (Result),
         Action    => Print_Skips'Access,
         Status    => "SKIPPED",
         Count     => Skipped_Count'Access,
         Print_Log => True);
   end Print_Skips;

   --
   -- Print all errors from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Errors (Result : Result_Collection;
                           Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Error (Result),
         Action    => Print_Errors'Access,
         Status    => "ERROR",
         Count     => Error_Count'Access,
         Print_Log => True);
   end Print_Errors;

   --
   -- Print all passes from the result collection
   -- and then recurse into child collections.
   --
   procedure Print_Passes (Result : Result_Collection;
                           Level  : Natural) is
   begin
      Print_Statuses
        (Result    => Result,
         Level     => Level,
         Start     => First_Pass (Result),
         Action    => Print_Passes'Access,
         Status    => "PASS",
         Count     => Pass_Count'Access,
         Print_Log => False);
   end Print_Passes;

   --
   -- Report passes, skips, failures, and errors from the result collection.
   procedure Report_Results (Result  : Result_Collection;
                             Verbose : Boolean := False) is
   begin
      Put_Line ("Passed : " & Integer'Image (Pass_Count (Result)));
      if Verbose then
         Print_Passes (Result, 0);
      end if;
      New_Line;
      if Skipped_Count (Result) > 0 then
         Put_Line ("Skipped : " & Integer'Image (Skipped_Count (Result)));
         Print_Skips (Result, 0);
         New_Line;
      end if;
      if Failure_Count (Result) > 0 then
         Put_Line ("Failed : " & Integer'Image (Failure_Count (Result)));
         Print_Failures (Result, 0);
         New_Line;
      end if;
      if Error_Count (Result) > 0 then
         Put_Line ("Errors : " & Integer'Image (Error_Count (Result)));
         Print_Errors (Result, 0);
      end if;
   end Report_Results;

   procedure Print_Log_File (Filename : String) is
      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;
   begin
      Open (Handle, In_File, Filename);
      begin
         loop
            exit when End_Of_File (Handle);
            Get (Handle, Char);
            if First then
               Put_Line ("===== Output =======");
               First := False;
            end if;
            Put (Char);
            if End_Of_Line (Handle) then
               New_Line;
            end if;

         end loop;

         --  The End_Error exception is sometimes raised.
      exception
         when Ada.IO_Exceptions.End_Error =>
            null;

      end;
      Close (Handle);
      if not First then
         Put_Line ("====================");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      if Parameters.XML_Results (Args) then
         XML_Runner.Report_Results
           (Test_Results, Parameters.Result_Dir (Args));
      else
         Report_Results (Test_Results, Parameters.Verbose (Args));
      end if;
   end Do_Report;

   procedure Run (Suite : in out Framework.Test'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.Text_Runner;

Fix the Ahven text runner: the END_ERROR exception can be raised when reading the test output file


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . E X P R _ S E M                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains routines needed for semantic queries from
--  the Asis.Expressions package

with Asis; use Asis;

package A4G.Expr_Sem is

   --  All the routines defined in this package do not check their
   --  arguments - a caller is responsible for the proper use of these
   --  routines

   function Expr_Type (Expression : Asis.Expression) return Asis.Declaration;
   --  using the fact, that Expression is of An_Expression kind and that
   --  the Etype field is set for its Node, this function finds the
   --  type declaration which should be returned as the result of
   --  Corresponding_Expression_Type (Expression)

   function Identifier_Name_Definition
     (Reference_I : Element)
      return        Asis.Defining_Name;

   function Character_Literal_Name_Definition
     (Reference_Ch : Element)
      return         Asis.Defining_Name;
   --  Each of these two functions provides an Element representing the
   --  defining occurrence for its argument, provided that the argument is
   --  of appropriate kind and all the necessary checks have already been
   --  done

   function Is_Reference
     (Name : Asis.Element;
      Ref  : Asis.Element)
      return Boolean;
   --  Provided that Name is of A_Defining_Name kind, this function checks is
   --  Ref is a reference to this name. It is an error to call this function
   --  for any Element which is not of A_Defining_Name as an actual for Name.
   --  Any Element is acceptable as an actual for Ref, and this function does
   --  not raise any exception in any case.
   --
   --  ??? Should we move this function into Asis.Extensions?

   function Needs_List (Reference : Asis.Element) return Boolean;
   --  Supposed to be applied to the argument of the
   --  Corresponding_Name_Definition_List query. Checks if Reference
   --  is ambiguous and refers to more than one entity.

   procedure Collect_Overloaded_Entities (Reference : Asis.Element);
   --  Supposed to be called for the argument of the
   --  Corresponding_Name_Definition_List query in case if Needs_List is
   --  True for it. Collects in the Element Table all the defining
   --  names referred by Reference.
   --  This procedure supposes, that the Element Table is already initialized
   --  in the calling context

   procedure Correct_Result
     (Result    : in out Element;
      Reference :        Element);
   --  This procedure implements a most complicated case for the fix needed
   --  for BB10-002. It correct the result in the situation when we have nested
   --  generic instantiations, and the named number in question is declared in
   --  template. In this situation the approach based on Original_Entity field
   --  returns the defining name from the template, but we need the defining
   --  name from the outer instantiation (see the test for BB10-002 for more
   --  details)

   function Is_From_Dispatching_Call (Reference : Element) return Boolean;
   --  This function detects if its argument is a name from a dispatching call
   --  for that Corresponding_Name_Definition should return Nil_Element (that
   --  is, a name of a called subprogram or the name of a formal parameter from
   --  a named association)

   function Is_Implicit_Formal_Par (Result_El : Element) return Boolean;
   --  Is supposed to be applied to the result of Identifier_Name_Definition.
   --  Checks if this result corresponds to the situation when the argument of
   --  Identifier_Name_Definition is the reference to a formal parameter from
   --  implicit inherited subprogram

   procedure Correct_Impl_Form_Par
     (Result    : in out Element;
      Reference :        Element);
   --  This procedure is supposed to be called is Result is the result of the
   --  call to Identifier_Name_Definition, and Is_Implicit_Formal_Par yields
   --  True for Result. It creates the correct defining name for this iplicit
   --  inherited formal parameter.

end A4G.Expr_Sem;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . K N D _ C O N V                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 15351 $
--                                                                          --
--            Copyright (c) 1995-2002, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Set_Get;
with A4G.Knd_Conv; use A4G.Knd_Conv;
with A4G.Vcheck;   use A4G.Vcheck;

package body Asis.Extensions.Flat_Kinds is

   use Asis;

   -----------------------
   -- Flat_Element_Kind --
   -----------------------

   function Flat_Element_Kind
     (Element : Asis.Element)
      return    Flat_Element_Kinds
   is
   begin
      Check_Validity (Element, "Asis.Extensions.Flat_Kinds.Flat_Element_Kind");

      return Flat_Element_Kinds (Asis.Set_Get.Int_Kind (Element));
   end Flat_Element_Kind;

   -------------------------------------------------
   -- Flat Element Kinds Conversion Functions --
   -------------------------------------------------

   function Asis_From_Flat_Kind
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Element_Kinds
   is
   begin
      return Asis_From_Internal_Kind (Internal_Element_Kinds (Flat_Kind));
   end Asis_From_Flat_Kind;

   function Pragma_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Pragma_Kinds
   is
   begin
      return Pragma_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Pragma_Kind_From_Flat;

   function Defining_Name_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Defining_Name_Kinds
   is
   begin
      return Defining_Name_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Defining_Name_Kind_From_Flat;

   function Declaration_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Declaration_Kinds
   is
   begin
      return Declaration_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Declaration_Kind_From_Flat;

   function Definition_Kind_From_Flat
      (Flat_Kind : Flat_Element_Kinds)
       return      Asis.Definition_Kinds
   is
   begin
      return Definition_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Definition_Kind_From_Flat;

   function Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Type_Kinds
   is
   begin
      return Type_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Type_Kind_From_Flat;

   function Formal_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Formal_Type_Kinds
   is
   begin
      return Formal_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Formal_Type_Kind_From_Flat;

   function Access_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Access_Type_Kinds
   is
   begin
      return Access_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Access_Type_Kind_From_Flat;

   function Root_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Root_Type_Kinds
   is
   begin
      return Root_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Root_Type_Kind_From_Flat;

   function Constraint_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Constraint_Kinds
   is
   begin
      return Constraint_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Constraint_Kind_From_Flat;

   function Discrete_Range_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Discrete_Range_Kinds
   is
   begin
      return Discrete_Range_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Discrete_Range_Kind_From_Flat;

   function Expression_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Expression_Kinds
   is
   begin
      return Expression_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Expression_Kind_From_Flat;

   function Operator_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Operator_Kinds
   is
   begin
      return Operator_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Operator_Kind_From_Flat;

   function Attribute_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Attribute_Kinds
   is
   begin
      return Attribute_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Attribute_Kind_From_Flat;

   function Association_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Association_Kinds
   is
   begin
      return Association_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Association_Kind_From_Flat;

   function Statement_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Statement_Kinds
   is
   begin
      return Statement_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Statement_Kind_From_Flat;

   function Path_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Path_Kinds
   is
   begin
      return Path_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Path_Kind_From_Flat;

   function Clause_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Clause_Kinds
   is
   begin
      return Clause_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Clause_Kind_From_Flat;

   function Representation_Clause_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Representation_Clause_Kinds
   is
   begin
      return Representation_Clause_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Representation_Clause_Kind_From_Flat;

   -------------------------------------
   -- Additional Classification items --
   -------------------------------------

   -----------------------
   -- Def_Operator_Kind --
   -----------------------

   function Def_Operator_Kind
     (Op_Kind : Flat_Element_Kinds)
      return    Flat_Element_Kinds
   is
   begin
      return Flat_Element_Kinds (Def_Operator_Kind
               (Internal_Element_Kinds (Op_Kind)));
   end Def_Operator_Kind;

end Asis.Extensions.Flat_Kinds;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 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 Ada.Strings.Fixed;
with Ada.Text_IO;

with Util.Http.Clients;
with Util.Strings;
with Util.Encoders;
with Util.Log.Loggers;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
package body Security.Auth.OpenID is

   use Ada.Strings.Fixed;
   use Util.Log;

   Log : constant Util.Log.Loggers.Logger := Loggers.Create ("Security.Auth.OpenID");

   procedure Extract_Profile (Prefix  : in String;
                              Request : in Parameters'Class;
                              Result  : in out Authentication);

   function Extract (From      : String;
                     Start_Tag : String;
                     End_Tag   : String) return String;

   procedure Extract_Value (Into    : in out Unbounded_String;
                            Request : in Parameters'Class;
                            Name    : in String);

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

   function Get_Association_Query return String;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   --  Initialize the authentication realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID) is
   begin
      Realm.Realm     := To_Unbounded_String (Params.Get_Parameter (Provider & ".realm"));
      Realm.Return_To := To_Unbounded_String (Params.Get_Parameter (Provider & ".callback_url"));
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
      Client : Util.Http.Clients.Client;
      Reply  : Util.Http.Clients.Response;
   begin
      Log.Info ("Discover XRDS on {0}", Name);

      Client.Add_Header ("Accept", "application/xrds+xml");
      Client.Get (URL   => Name,
                  Reply => Reply);
      if Reply.Get_Status /= Util.Http.SC_OK then
         Log.Error ("Received error {0} when discovering XRDS on {1}",
                    Util.Strings.Image (Reply.Get_Status), Name);
         raise Service_Error with "Discovering XRDS of OpenID provider failed.";
      end if;

      Manager'Class (Realm).Extract_XRDS (Content => Reply.Get_Body,
                                          Result  => Result);
   end Discover;

   function Extract (From      : String;
                     Start_Tag : String;
                     End_Tag   : String) return String is
      Pos  : Natural := Index (From, Start_Tag);
      Last : Natural;
      Url_Pos : Natural;
   begin
      if Pos = 0 then
         Pos := Index (From, Start_Tag (Start_Tag'First .. Start_Tag'Last - 1));
         if Pos = 0 then
            return "";
         end if;
         Pos := Index (From, ">", Pos + 1);
         if Pos = 0 then
            return "";
         end if;
         Url_Pos := Pos + 1;
      else
         Url_Pos := Pos + Start_Tag'Length;
      end if;
      Last := Index (From, End_Tag, Pos);
      if Last <= Pos then
         return "";
      end if;
      return From (Url_Pos .. Last - 1);
   end Extract;

   --  ------------------------------
   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   --  ------------------------------
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point) is
      pragma Unreferenced (Realm);

      URI : constant String := Extract (Content, "<URI>", "</URI>");
   begin
      if URI'Length = 0 then
         raise Invalid_End_Point with "Cannot extract the <URI> from the XRDS document";
      end if;
      Result.URL := To_Unbounded_String (URI);
   end Extract_XRDS;

   function Get_Association_Query return String is
   begin
      return "openid.ns=http://specs.openid.net/auth/2.0&"
        & "openid.mode=associate&"
        & "openid.session_type=no-encryption&"
        & "openid.assoc_type=HMAC-SHA1";
   end Get_Association_Query;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
      pragma Unreferenced (Realm);

      Output : Unbounded_String;
      URI    : constant String := To_String (OP.URL);
      Params : constant String := Get_Association_Query;
      Client : Util.Http.Clients.Client;
      Reply  : Util.Http.Clients.Response;
      Pos, Last, N : Natural;
   begin
      Client.Post (URL   => URI,
                   Data  => Params,
                   Reply => Reply);
      if Reply.Get_Status /= Util.Http.SC_OK then
         Log.Error ("Received error {0} when creating assoication with {1}",
                    Util.Strings.Image (Reply.Get_Status), URI);
         raise Service_Error with "Cannot create association with OpenID provider.";
      end if;
      Output := To_Unbounded_String (Reply.Get_Body);
      Pos := 1;
      while Pos < Length (Output) loop
         N := Index (Output, ":", Pos);
         exit when N = 0;
         Last := Index (Output, "" & ASCII.LF, N);
         if Last = 0 then
            Last := Length (Output);
         else
            Last := Last - 1;
         end if;
         declare
            Key : constant String := Slice (Output, Pos, N - 1);
         begin
            if Key = "session_type" then
               Result.Session_Type := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "assoc_type" then
               Result.Assoc_Type := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "assoc_handle" then
               Result.Assoc_Handle := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "mac_key" then
               Result.Mac_Key := Unbounded_Slice (Output, N + 1, Last);
            elsif Key = "expires_in" then
               declare
                  Val : constant String := Slice (Output, N + 1, Last);
                  --                    Expires : Integer := Integer'Value (Val);
               begin
                  Ada.Text_IO.Put_Line ("Expires: |" & Val & "|");
                  Result.Expired := Ada.Calendar.Clock;
               end;
            elsif Key /= "ns" then
               Ada.Text_IO.Put_Line ("Key not recognized: " & Key);
            end if;
         end;
         Pos := Last + 2;
      end loop;
      Log.Debug ("Received end point {0}", To_String (Output));
   end Associate;

   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
      Result : Unbounded_String := OP.URL;
      Axa : constant String := "ax";
   begin
      if Index (Result, "?") > 0 then
         Append (Result, "&");
      else
         Append (Result, "?");
      end if;
      Append (Result, "openid.ns=http://specs.openid.net/auth/2.0");
      Append (Result, "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select");
      Append (Result, "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select");
      Append (Result, "&openid.mode=checkid_setup");
      Append (Result, "&openid.ns." & Axa & "=http://openid.net/srv/ax/1.0");
      Append (Result, "&openid." & Axa & ".mode=fetch_request");
      Append (Result, "&openid." & Axa & ".type.email=http://axschema.org/contact/email");
      Append (Result, "&openid." & Axa & ".type.fullname=http://axschema.org/namePerson");
      Append (Result, "&openid." & Axa & ".type.language=http://axschema.org/pref/language");
      Append (Result, "&openid." & Axa & ".type.firstname=http://axschema.org/namePerson/first");
      Append (Result, "&openid." & Axa & ".type.lastname=http://axschema.org/namePerson/last");
      Append (Result, "&openid." & Axa & ".type.gender=http://axschema.org/person/gender");
      Append (Result, "&openid." & Axa & ".required=email,fullname,language,firstname,"
              & "lastname,gender");
      Append (Result, "&openid.ns.sreg=http://openid.net/extensions/sreg/1.1");
      Append (Result, "&openid.sreg.required=email,fullname,gender,country,nickname");
      Append (Result, "&openid.return_to=");
      Append (Result, Realm.Return_To);
      Append (Result, "&openid.assoc_handle=");
      Append (Result, Assoc.Assoc_Handle);
      Append (Result, "&openid.realm=");
      Append (Result, Realm.Realm);
      return To_String (Result);
   end Get_Authentication_URL;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String) is
   begin
      if Status /= AUTHENTICATED then
         Log.Error ("OpenID verification failed: {0}", Message);
      else
         Log.Info ("OpenID verification: {0}", Message);
      end if;
      Result.Status := Status;
   end Set_Result;

   procedure Extract_Value (Into    : in out Unbounded_String;
                            Request : in Parameters'Class;
                            Name    : in String) is
   begin
      if Length (Into) = 0 then
         Into := To_Unbounded_String (Request.Get_Parameter (Name));
      end if;
   end Extract_Value;

   procedure Extract_Profile (Prefix  : in String;
                              Request : in Parameters'Class;
                              Result  : in out Authentication) is
   begin
      Extract_Value (Result.Email, Request, Prefix & ".email");
      Extract_Value (Result.Nickname, Request, Prefix & ".nickname");
      Extract_Value (Result.Gender, Request, Prefix & ".gender");
      Extract_Value (Result.Country, Request, Prefix & ".country");
      Extract_Value (Result.Language, Request, Prefix & ".language");
      Extract_Value (Result.Full_Name, Request, Prefix & ".fullname");
      Extract_Value (Result.Timezone, Request, Prefix & ".timezone");
      Extract_Value (Result.First_Name, Request, Prefix & ".firstname");
      Extract_Value (Result.Last_Name, Request, Prefix & ".lastname");

      --  If the fullname is not specified, try to build one from the first_name and last_name.
      if Length (Result.Full_Name) = 0 then
         Append (Result.Full_Name, Result.First_Name);
         if Length (Result.First_Name) > 0 and Length (Result.Last_Name) > 0 then
            Append (Result.Full_Name, " ");
            Append (Result.Full_Name, Result.Last_Name);
         end if;
      end if;
   end Extract_Profile;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
      Mode : constant String := Request.Get_Parameter ("openid.mode");
   begin
      --  Step 1: verify the response status
      if Mode = "cancel" then
         Set_Result (Result, CANCEL, "Authentication refused");
         return;
      end if;

      if Mode = "setup_needed" then
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
         return;
      end if;

      if Mode /= "id_res" then
         Set_Result (Result, UNKNOWN, "Setup is needed");
         return;
      end if;

      --  OpenID Section: 11.1.  Verifying the Return URL
      declare
         Value : constant String := Request.Get_Parameter ("openid.return_to");
      begin
         if Value /= Realm.Return_To then
            Set_Result (Result, UNKNOWN, "openid.return_to URL does not match");
            return;
         end if;
      end;

      --  OpenID Section: 11.2.  Verifying Discovered Information
      Manager'Class (Realm).Verify_Discovered (Assoc, Request, Result);

      --  OpenID Section: 11.3.  Checking the Nonce
      declare
         Value : constant String := Request.Get_Parameter ("openid.response_nonce");
      begin
         if Value = "" then
            Set_Result (Result, UNKNOWN, "openid.response_nonce is empty");
            return;
         end if;
      end;

      --  OpenID Section: 11.4.  Verifying Signatures
      Manager'Class (Realm).Verify_Signature (Assoc, Request, Result);

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.sreg");
      begin
         --  Extract profile information
         if Value = "http://openid.net/extensions/sreg/1.1" then
            Extract_Profile ("openid.sreg", Request, Result);
         end if;
      end;

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.ax");
      begin
         if Value = "http://openid.net/srv/ax/1.0" then
            Extract_Profile ("openid.ax.value", Request, Result);
         end if;
      end;

      declare
         Value : constant String := Request.Get_Parameter ("openid.ns.ext1");
      begin
         if Value = "http://openid.net/srv/ax/1.0" then
            Extract_Profile ("openid.ext1.value", Request, Result);
         end if;
      end;
   end Verify;

   --  ------------------------------
   --  Verify the signature part of the result
   --  ------------------------------
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication) is
      pragma Unreferenced (Realm);

      use type Util.Encoders.SHA1.Digest;

      Signed : constant String := Request.Get_Parameter ("openid.signed");
      Len    : constant Natural := Signed'Length;
      Sign   : Unbounded_String;
      Param  : Unbounded_String;
      Pos    : Natural := 1;
      Last   : Natural;
   begin
      while Pos < Len loop
         Last := Index (Signed, ",", Pos);
         if Last > 0 then
            Param := To_Unbounded_String (Signed (Pos .. Last - 1));
            Pos  := Last + 1;
         else
            Param := To_Unbounded_String (Signed (Pos .. Len));
            Pos  := Len + 1;
         end if;
         declare
            Name  : constant String := "openid." & To_String (Param);
            Value : constant String := Request.Get_Parameter (Name);
         begin
            Append (Sign, Param);
            Append (Sign, ':');
            Append (Sign, Value);
            Append (Sign, ASCII.LF);
         end;
      end loop;
      Log.Info ("Signing: '{0}'", To_String (Sign));

      declare
         Decoder : constant Util.Encoders.Encoder := Util.Encoders.Create (Util.Encoders.BASE_64);
         S       : constant String := Request.Get_Parameter ("openid.sig");
         Key     : constant String := Decoder.Decode (To_String (Assoc.Mac_Key));

         R : constant Util.Encoders.SHA1.Base64_Digest
           := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key, To_String (Sign));
      begin
         Log.Info ("Signature: {0} - {1}", S, R);
         if R /= S then
            Set_Result (Result, INVALID_SIGNATURE, "openid.response_nonce is empty");
         else
            Set_Result (Result, AUTHENTICATED, "authenticated");
         end if;
      end;
   end Verify_Signature;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication) is
      pragma Unreferenced (Realm, Assoc);
   begin
      Result.Claimed_Id := To_Unbounded_String (Request.Get_Parameter ("openid.claimed_id"));
      Result.Identity   := To_Unbounded_String (Request.Get_Parameter ("openid.identity"));
   end Verify_Discovered;

   function To_String (Assoc : Association) return String is
   begin
      return "session_type=" & To_String (Assoc.Session_Type)
        & "&assoc_type=" & To_String (Assoc.Assoc_Type)
        & "&assoc_handle=" & To_String (Assoc.Assoc_Handle)
        & "&mac_key=" & To_String (Assoc.Mac_Key);
   end To_String;

end Security.Auth.OpenID;

Refactor the OpenID authentication to be based on the generic authentication framework