-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
with Security.Auth.OAuth.Googleplus;
package body Security.Auth is

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

   Def_Factory : Factory_Access := Default_Factory'Access;

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Default factory used by `Initialize`.  It supports OpenID, Google, Facebook.
   --  ------------------------------
   function Default_Factory (Provider : in String) return Manager_Access is
   begin
      if Provider = PROVIDER_OPENID then
         return new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         return new Security.Auth.OAuth.Facebook.Manager;

      elsif Provider = PROVIDER_GOOGLE_PLUS then
         return new Security.Auth.OAuth.Googleplus.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
   end Default_Factory;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
   begin
      Initialize (Realm, Params, Def_Factory, Name);
   end Initialize;

   procedure Initialize (Realm   : in out Manager;
                         Params  : in Parameters'Class;
                         Factory : not null
                         access function (Name : in String) return Manager_Access;
                         Name    : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : constant Manager_Access := Factory (Provider);
   begin
      if Impl = null then
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   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;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   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;

   --  ------------------------------
   --  Set the default factory to use.
   --  ------------------------------
   procedure Set_Default_Factory (Factory : in Factory_Access) is
   begin
      Def_Factory := Factory;
   end Set_Default_Factory;

   overriding
   procedure Finalize (Realm : in out Manager) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Manager'Class, Manager_Access);
   begin
      Free (Realm.Delegate);
   end Finalize;

end Security.Auth;

-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;

with Security.Auth.OpenID;
with Security.Auth.OAuth.Facebook;
with Security.Auth.OAuth.Googleplus;
with Security.Auth.OAuth.Yahoo;
with Security.Auth.OAuth.Github;
package body Security.Auth is

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

   Def_Factory : Factory_Access := Default_Factory'Access;

   --  ------------------------------
   --  Get the provider.
   --  ------------------------------
   function Get_Provider (Assoc : in Association) return String is
   begin
      return To_String (Assoc.Provider);
   end Get_Provider;

   --  ------------------------------
   --  Get the email address
   --  ------------------------------
   function Get_Email (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Email);
   end Get_Email;

   --  ------------------------------
   --  Get the user first name.
   --  ------------------------------
   function Get_First_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.First_Name);
   end Get_First_Name;

   --  ------------------------------
   --  Get the user last name.
   --  ------------------------------
   function Get_Last_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Last_Name);
   end Get_Last_Name;

   --  ------------------------------
   --  Get the user full name.
   --  ------------------------------
   function Get_Full_Name (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Full_Name);
   end Get_Full_Name;

   --  ------------------------------
   --  Get the user identity.
   --  ------------------------------
   function Get_Identity (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Identity);
   end Get_Identity;

   --  ------------------------------
   --  Get the user claimed identity.
   --  ------------------------------
   function Get_Claimed_Id (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Claimed_Id);
   end Get_Claimed_Id;

   --  ------------------------------
   --  Get the user language.
   --  ------------------------------
   function Get_Language (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Language);
   end Get_Language;

   --  ------------------------------
   --  Get the user country.
   --  ------------------------------
   function Get_Country (Auth : in Authentication) return String is
   begin
      return To_String (Auth.Country);
   end Get_Country;

   --  ------------------------------
   --  Get the result of the authentication.
   --  ------------------------------
   function Get_Status (Auth : in Authentication) return Auth_Result is
   begin
      return Auth.Status;
   end Get_Status;

   --  ------------------------------
   --  Default principal
   --  ------------------------------

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return Get_First_Name (From.Auth) & " " & Get_Last_Name (From.Auth);
   end Get_Name;

   --  ------------------------------
   --  Get the user email address.
   --  ------------------------------
   function Get_Email (From : in Principal) return String is
   begin
      return Get_Email (From.Auth);
   end Get_Email;

   --  ------------------------------
   --  Get the authentication data.
   --  ------------------------------
   function Get_Authentication (From : in Principal) return Authentication is
   begin
      return From.Auth;
   end Get_Authentication;

   --  ------------------------------
   --  Create a principal with the given authentication results.
   --  ------------------------------
   function Create_Principal (Auth : in Authentication) return Principal_Access is
      P : constant Principal_Access := new Principal;
   begin
      P.Auth := Auth;
      return P;
   end Create_Principal;

   --  ------------------------------
   --  Default factory used by `Initialize`.  It supports OpenID, Google, Facebook.
   --  ------------------------------
   function Default_Factory (Provider : in String) return Manager_Access is
   begin
      if Provider = PROVIDER_OPENID then
         return new Security.Auth.OpenID.Manager;

      elsif Provider = PROVIDER_FACEBOOK then
         return new Security.Auth.OAuth.Facebook.Manager;

      elsif Provider = PROVIDER_GOOGLE_PLUS then
         return new Security.Auth.OAuth.Googleplus.Manager;

      elsif Provider = PROVIDER_YAHOO then
         return new Security.Auth.OAuth.Yahoo.Manager;

      elsif Provider = PROVIDER_GITHUB then
         return new Security.Auth.OAuth.Github.Manager;

      else
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
   end Default_Factory;

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm  : in out Manager;
                         Params : in Parameters'Class;
                         Name   : in String := PROVIDER_OPENID) is
   begin
      Initialize (Realm, Params, Def_Factory, Name);
   end Initialize;

   procedure Initialize (Realm   : in out Manager;
                         Params  : in Parameters'Class;
                         Factory : not null
                         access function (Name : in String) return Manager_Access;
                         Name    : in String := PROVIDER_OPENID) is
      Provider : constant String := Params.Get_Parameter ("auth.provider." & Name);
      Impl     : constant Manager_Access := Factory (Provider);
   begin
      if Impl = null then
         Log.Error ("Authentication provider {0} not recognized", Provider);
         raise Service_Error with "Authentication provider not supported";
      end if;
      Realm.Delegate := Impl;
      Impl.Initialize (Params, Name);
      Realm.Provider := To_Unbounded_String (Name);
   end Initialize;

   --  ------------------------------
   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The <b>Name</b> can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   --  ------------------------------
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Discover (Name, Result);
      else
--           Result.URL := Realm.Realm;
         Result.Alias := To_Unbounded_String ("");
      end if;
   end Discover;

   --  ------------------------------
   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   --  ------------------------------
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association) is
   begin
      Result.Provider := Realm.Provider;
      if Realm.Delegate /= null then
         Realm.Delegate.Associate (OP, Result);
      end if;
   end Associate;

   --  ------------------------------
   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   --  ------------------------------
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String is
   begin
      if Realm.Delegate /= null then
         return Realm.Delegate.Get_Authentication_URL (OP, Assoc);
      else
         return To_String (OP.URL);
      end if;
   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;

   --  ------------------------------
   --  Verify the authentication result
   --  ------------------------------
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication) is
   begin
      if Realm.Delegate /= null then
         Realm.Delegate.Verify (Assoc, Request, Result);
      else
         Set_Result (Result, SETUP_NEEDED, "Setup is needed");
      end if;
   end Verify;

   function To_String (OP : End_Point) return String is
   begin
      return "openid://" & To_String (OP.URL);
   end To_String;

   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;

   --  ------------------------------
   --  Set the default factory to use.
   --  ------------------------------
   procedure Set_Default_Factory (Factory : in Factory_Access) is
   begin
      Def_Factory := Factory;
   end Set_Default_Factory;

   overriding
   procedure Finalize (Realm : in out Manager) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Manager'Class, Manager_Access);
   begin
      Free (Realm.Delegate);
   end Finalize;

end Security.Auth;

Update to recognize the Yahoo and Github providers


-----------------------------------------------------------------------
--  gen-model-projects -- Projects meta data
--  Copyright (C) 2011, 2012, 2013, 2014, 2017, 2018, 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 Ada.Strings.Unbounded;
with Ada.Containers.Vectors;

with Util.Beans.Objects;
with Util.Properties;

with Gen.Utils;
with Gen.Utils.GNAT;
package Gen.Model.Projects is

   use Ada.Strings.Unbounded;

   type Project_Definition is tagged;
   type Project_Definition_Access is access all Project_Definition'Class;

   type Dependency_Type is (NONE, DIRECT, INDIRECT, BOTH);

   type Project_Reference is record
      Project : Project_Definition_Access := null;
      Name    : Unbounded_String;
      Kind    : Dependency_Type := NONE;
   end record;

   package Project_Vectors is
     new Ada.Containers.Vectors (Element_Type => Project_Reference,
                                 Index_Type   => Natural);

   --  ------------------------------
   --  Project Definition
   --  ------------------------------
   type Project_Definition is new Definition with record
      Path    : Unbounded_String;
      Props   : Util.Properties.Manager;
      Modules : Project_Vectors.Vector;

      --  The root project definition.
      Root          : Project_Definition_Access := null;

      --  The list of plugin names that this plugin or project depends on.
      Dependencies  : Project_Vectors.Vector;

      --  The list of GNAT project files used by the project.
      Project_Files : Gen.Utils.GNAT.Project_Info_Vectors.Vector;

      --  The list of 'dynamo.xml' files used by the project (gathered from GNAT files
      --  and by scanning the 'plugins' directory).
      Dynamo_Files  : Gen.Utils.String_List.Vector;

      --  Whether we did a recursive scan of GNAT project files.
      Recursive_Scan : Boolean := False;

      --  Whether we are doing a recursive operation on the project (prevent from cycles).
      Recursing      : Boolean := False;

      --  Whether we did a recursive scan of Dynamo dependencies.
      Depend_Scan    : Boolean := False;

      --  Whether this project is a plugin.
      Is_Plugin      : Boolean := False;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Project_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Get the project name.
   function Get_Project_Name (Project : in Project_Definition) return String;

   --  Get the GNAT project file name.  The default is to use the Dynamo project
   --  name and add the .gpr extension.  The gnat_project configuration
   --  property allows to override this default.
   function Get_GNAT_Project_Name (Project : in Project_Definition) return String;

   --  Get the directory path which holds application modules.
   --  This is controlled by the modules_dir configuration property.
   --  The default is <tt>plugins</tt>.
   --  ------------------------------
   function Get_Module_Dir (Project : in Project_Definition) return String;

   --  Find the dependency for the Name plugin.
   --  Returns a null dependency if the project does not depend on that plugin.
   function Find_Dependency (From : in Project_Definition;
                             Name : in String) return Project_Reference;

   --  Add a dependency to the plugin identified by Name.
   procedure Add_Dependency (Into : in out Project_Definition;
                             Name : in String;
                             Kind : in Dependency_Type);

   --  Add a dependency to the plugin identified by Project.
   procedure Add_Dependency (Into    : in out Project_Definition;
                             Project : in Project_Definition_Access;
                             Kind    : in Dependency_Type);

   --  Create a project definition instance to record a project with the dynamo XML file path.
   procedure Create_Project (Into    : in out Project_Definition;
                             Name    : in String;
                             Path    : in String;
                             Project : out Project_Definition_Access);

   --  Add the project in the global project list on the root project instance.
   procedure Add_Project (Into    : in out Project_Definition;
                          Project : in Project_Definition_Access);

   --  Add the project Name as a module.
   procedure Add_Module (Into : in out Project_Definition;
                         Name : in String);

   --  Add the project represented by Project if it is not already part of the modules.
   procedure Add_Module (Into    : in out Project_Definition;
                         Project : in Project_Definition_Access);

   --  Find the project definition associated with the dynamo XML file Path.
   --  Returns null if there is no such project
   function Find_Project (From : in Project_Definition;
                          Path : in String) return Project_Definition_Access;

   --  Find the project definition having the name Name.
   --  Returns null if there is no such project
   function Find_Project_By_Name (From : in Project_Definition;
                                  Name : in String) return Project_Definition_Access;

   --  Save the project description and parameters.
   procedure Save (Project : in out Project_Definition;
                   Path    : in String);

   --  Read the XML project description into the project description.
   procedure Read_Project (Project : in out Project_Definition);

   --  Scan and read the possible modules used by the application.  Modules are stored in the
   --  modules directory.  Each module is stored in its own directory and has its own
   --  dynamo.xml file.
   procedure Read_Modules (Project  : in out Project_Definition);

   --  Update the project definition from the properties.
   procedure Update_From_Properties (Project : in out Project_Definition);

   --  ------------------------------
   --  Root Project Definition
   --  ------------------------------
   --  The root project is the project that is actually read by Dynamo.
   --  It contains the lists of all projects that are necessary and which are found either
   --  by scanning GNAT projects or by looking at plugin dependencies.
   type Root_Project_Definition is new Project_Definition with record
      Projects    : Project_Vectors.Vector;

      Install_Dir : Unbounded_String;
   end record;

   --  Add the project in the global project list on the root project instance.
   overriding
   procedure Add_Project (Into    : in out Root_Project_Definition;
                          Project : in Project_Definition_Access);

   --  Find the project definition having the name Name.
   --  Returns null if there is no such project
   overriding
   function Find_Project_By_Name (From : in Root_Project_Definition;
                                  Name : in String) return Project_Definition_Access;

   --  Find the project definition associated with the dynamo XML file Path.
   --  Returns null if there is no such project
   overriding
   function Find_Project (From : in Root_Project_Definition;
                          Path : in String) return Project_Definition_Access;

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (Project   : in out Root_Project_Definition;
                           File      : in String;
                           Config    : in Util.Properties.Manager'Class;
                           Recursive : in Boolean := False);

private

   --  Update the project references after a project is found and initialized.
   procedure Update_References (Root    : in out Root_Project_Definition;
                                Project : in Project_Definition_Access);

   --  Iterate over the project referenced in the list and execute the Process procedure.
   procedure Iterate (List    : in out Project_Vectors.Vector;
                      Process : access procedure (Item : in out Project_Reference));

   --  Find a project from the list
   function Find_Project (List : in Project_Vectors.Vector;
                          Name : in String) return Project_Reference;

end Gen.Model.Projects;

-----------------------------------------------------------------------
--  gen-model-projects -- Projects meta data
--  Copyright (C) 2011, 2012, 2013, 2014, 2017, 2018, 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 Ada.Strings.Unbounded;
with Ada.Containers.Vectors;

with Util.Beans.Objects;
with Util.Properties;

with Gen.Utils;
with Gen.Utils.GNAT;
package Gen.Model.Projects is

   use Ada.Strings.Unbounded;

   type Project_Definition is tagged;
   type Project_Definition_Access is access all Project_Definition'Class;

   type Dependency_Type is (NONE, DIRECT, INDIRECT, BOTH);

   type Project_Reference is record
      Project : Project_Definition_Access := null;
      Name    : Unbounded_String;
      Kind    : Dependency_Type := NONE;
   end record;

   package Project_Vectors is
     new Ada.Containers.Vectors (Element_Type => Project_Reference,
                                 Index_Type   => Natural);

   --  ------------------------------
   --  Project Definition
   --  ------------------------------
   type Project_Definition is new Definition with record
      Path    : Unbounded_String;
      Props   : Util.Properties.Manager;
      Modules : Project_Vectors.Vector;

      --  The root project definition.
      Root          : Project_Definition_Access := null;

      --  The list of plugin names that this plugin or project depends on.
      Dependencies  : Project_Vectors.Vector;

      --  The list of GNAT project files used by the project.
      Project_Files : Gen.Utils.GNAT.Project_Info_Vectors.Vector;

      --  The list of 'dynamo.xml' files used by the project (gathered from GNAT files
      --  and by scanning the 'plugins' directory).
      Dynamo_Files  : Gen.Utils.String_List.Vector;

      --  Whether we did a recursive scan of GNAT project files.
      Recursive_Scan : Boolean := False;

      --  Whether we are doing a recursive operation on the project (prevent from cycles).
      Recursing      : Boolean := False;

      --  Whether we did a recursive scan of Dynamo dependencies.
      Depend_Scan    : Boolean := False;

      --  Whether this project is a plugin.
      Is_Plugin      : Boolean := False;

      --  Whether the project needs the generation for the different databases
      Use_Mysql      : Boolean := True;
      Use_Sqlite     : Boolean := True;
      Use_Postgresql : Boolean := True;
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : Project_Definition;
                       Name : String) return Util.Beans.Objects.Object;

   --  Get the project name.
   function Get_Project_Name (Project : in Project_Definition) return String;

   --  Get the GNAT project file name.  The default is to use the Dynamo project
   --  name and add the .gpr extension.  The gnat_project configuration
   --  property allows to override this default.
   function Get_GNAT_Project_Name (Project : in Project_Definition) return String;

   --  Get the directory path which holds application modules.
   --  This is controlled by the modules_dir configuration property.
   --  The default is <tt>plugins</tt>.
   --  ------------------------------
   function Get_Module_Dir (Project : in Project_Definition) return String;

   --  Find the dependency for the Name plugin.
   --  Returns a null dependency if the project does not depend on that plugin.
   function Find_Dependency (From : in Project_Definition;
                             Name : in String) return Project_Reference;

   --  Add a dependency to the plugin identified by Name.
   procedure Add_Dependency (Into : in out Project_Definition;
                             Name : in String;
                             Kind : in Dependency_Type);

   --  Add a dependency to the plugin identified by Project.
   procedure Add_Dependency (Into    : in out Project_Definition;
                             Project : in Project_Definition_Access;
                             Kind    : in Dependency_Type);

   --  Create a project definition instance to record a project with the dynamo XML file path.
   procedure Create_Project (Into    : in out Project_Definition;
                             Name    : in String;
                             Path    : in String;
                             Project : out Project_Definition_Access);

   --  Add the project in the global project list on the root project instance.
   procedure Add_Project (Into    : in out Project_Definition;
                          Project : in Project_Definition_Access);

   --  Add the project Name as a module.
   procedure Add_Module (Into : in out Project_Definition;
                         Name : in String);

   --  Add the project represented by Project if it is not already part of the modules.
   procedure Add_Module (Into    : in out Project_Definition;
                         Project : in Project_Definition_Access);

   --  Find the project definition associated with the dynamo XML file Path.
   --  Returns null if there is no such project
   function Find_Project (From : in Project_Definition;
                          Path : in String) return Project_Definition_Access;

   --  Find the project definition having the name Name.
   --  Returns null if there is no such project
   function Find_Project_By_Name (From : in Project_Definition;
                                  Name : in String) return Project_Definition_Access;

   --  Save the project description and parameters.
   procedure Save (Project : in out Project_Definition;
                   Path    : in String);

   --  Read the XML project description into the project description.
   procedure Read_Project (Project : in out Project_Definition);

   --  Scan and read the possible modules used by the application.  Modules are stored in the
   --  modules directory.  Each module is stored in its own directory and has its own
   --  dynamo.xml file.
   procedure Read_Modules (Project  : in out Project_Definition);

   --  Update the project definition from the properties.
   procedure Update_From_Properties (Project : in out Project_Definition);

   --  ------------------------------
   --  Root Project Definition
   --  ------------------------------
   --  The root project is the project that is actually read by Dynamo.
   --  It contains the lists of all projects that are necessary and which are found either
   --  by scanning GNAT projects or by looking at plugin dependencies.
   type Root_Project_Definition is new Project_Definition with record
      Projects    : Project_Vectors.Vector;

      Install_Dir : Unbounded_String;
   end record;

   --  Add the project in the global project list on the root project instance.
   overriding
   procedure Add_Project (Into    : in out Root_Project_Definition;
                          Project : in Project_Definition_Access);

   --  Find the project definition having the name Name.
   --  Returns null if there is no such project
   overriding
   function Find_Project_By_Name (From : in Root_Project_Definition;
                                  Name : in String) return Project_Definition_Access;

   --  Find the project definition associated with the dynamo XML file Path.
   --  Returns null if there is no such project
   overriding
   function Find_Project (From : in Root_Project_Definition;
                          Path : in String) return Project_Definition_Access;

   --  Read the XML project file.  When Recursive is set, read the GNAT project
   --  files used by the main project and load all the dynamo.xml files defined
   --  by these project.
   procedure Read_Project (Project   : in out Root_Project_Definition;
                           File      : in String;
                           Config    : in Util.Properties.Manager'Class;
                           Recursive : in Boolean := False);

private

   --  Update the project references after a project is found and initialized.
   procedure Update_References (Root    : in out Root_Project_Definition;
                                Project : in Project_Definition_Access);

   --  Iterate over the project referenced in the list and execute the Process procedure.
   procedure Iterate (List    : in out Project_Vectors.Vector;
                      Process : access procedure (Item : in out Project_Reference));

   --  Find a project from the list
   function Find_Project (List : in Project_Vectors.Vector;
                          Name : in String) return Project_Reference;

end Gen.Model.Projects;

Fix #9: add Use_Mysql, Use_Sqlite and Use_Postresql to control the SQL generation on the project


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . E N C L _ E L                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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 for computing the enclosing element
--  for the Asis.Elements.Enclosing_Element function

with Asis;

package A4G.Encl_El is

   function Corresponding_Instantiation
     (Element : Asis.Element)
      return Asis.Element;
   --  This function accepts an Element representing an expanded generic
   --  declaration as an argument and returns the generic instantiation
   --  which was expanded in the argument declaration. According to subclause
   --  15.26, this instantiation should be returned as the Enclosing_Element
   --  for the expanded generic declaration.
   --
   --  Should we move this function in Asis.Extensions?

   function Enclosing_For_Explicit_Instance_Component
     (Element : Asis.Element)
      return Asis.Element;
   --  Computes the Enclosing Element for an explicit component of an
   --  expanded generic declaration. The problem in this case is, that if
   --  the result represents the whole expanded declaration, the
   --  Special_Case field of the result should be properly set

   function Enclosing_Element_For_Explicit
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for explicit
   --  elements

   function Enclosing_Element_For_Implicit
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for implicit
   --  elements. It's only partially implemented for now.

   function Enclosing_Element_For_Limited_View
     (Element : Asis.Element)
      return Asis.Element;
   --  This is the general constructor of enclosing element for elements from
   --  limited view.

end A4G.Encl_El;

Add the ASIS file $i

Add the ASIS file $i


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

package body Util.Concurrent.Counters is

   use Interfaces;

   function Sync_Add_And_Fetch
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Add_And_Fetch,
                  External_Name => "__sync_add_and_fetch_4");

   function Sync_Fetch_And_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Integer_32) return Interfaces.Unsigned_32;
   pragma Import (Intrinsic, Sync_Fetch_And_Add,
                  External_Name => "__sync_fetch_and_add_4");

   procedure Sync_Add
     (Ptr   : access Interfaces.Unsigned_32;
      Value : Interfaces.Unsigned_32);
   pragma Import (Intrinsic, Sync_Add,
                  External_Name => "__sync_add_and_fetch_4");

   --  ------------------------------
   --  Increment the counter atomically.
   --  ------------------------------
   procedure Increment (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, 1);
   end Increment;

   --  ------------------------------
   --  Increment the counter atomically and return the value before increment.
   --  ------------------------------
   procedure Increment (C     : in out Counter;
                        Value : out Integer) is
   begin
      Value := Integer (Sync_Fetch_And_Add (C.Value'Unrestricted_Access, 1));
   end Increment;

   --  ------------------------------
   --  Decrement the counter atomically.
   --  ------------------------------
   procedure Decrement (C : in out Counter) is
   begin
      Sync_Add (C.Value'Unrestricted_Access, -1);
   end Decrement;

   --  ------------------------------
   --  Decrement the counter atomically and return a status.
   --  ------------------------------
   procedure Decrement (C : in out Counter;
                        Is_Zero : out Boolean) is
      Value : Unsigned_32;
   begin
      Value := Sync_Add_And_Fetch (C.Value'Unrestricted_Access, -1);
      Is_Zero := Value /= 0;
   end Decrement;

   --  ------------------------------
   --  Get the counter value
   --  ------------------------------
   function Value (C : in Counter) return Integer is
   begin
      return Integer (C.Value);
   end Value;

end Util.Concurrent.Counters;

Implement the atomic counters using the gcc builtins __sync_add_and_fetch_4 and __sync_fetch_and_add_4


-----------------------------------------------------------------------
--  wiki-nodes-lists -- Wiki Document Internal representation
--  Copyright (C) 2016, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
package body Wiki.Nodes.Lists is

   --  ------------------------------
   --  Append a node to the node list.
   --  ------------------------------
   procedure Append (Into : in out Node_List_Ref;
                     Node : in Node_Type_Access) is
   begin
      if Into.Is_Null then
         Node_List_Refs.Ref (Into) := Node_List_Refs.Create;
         Into.Value.Current := Into.Value.First'Access;
      end if;
      Append (Into.Value, Node);
   end Append;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (List    : in Node_List_Accessor;
                      Process : not null access procedure (Node : in Node_Type)) is
      Block : Node_List_Block_Access := List.First'Access;
   begin
      loop
         for I in 1 .. Block.Last loop
            Process (Block.List (I).all);
         end loop;
         Block := Block.Next;
         exit when Block = null;
      end loop;
   end Iterate;

   procedure Iterate (List    : in Node_List_Access;
                      Process : not null access procedure (Node : in Node_Type)) is
      Block : Node_List_Block_Access := List.First'Access;
   begin
      loop
         for I in 1 .. Block.Last loop
            Process (Block.List (I).all);
         end loop;
         Block := Block.Next;
         exit when Block = null;
      end loop;
   end Iterate;

   --  ------------------------------
   --  Iterate over the nodes of the list and call the <tt>Process</tt> procedure with
   --  each node instance.
   --  ------------------------------
   procedure Iterate (List    : in Node_List_Ref;
                      Process : not null access procedure (Node : in Node_Type)) is
   begin
      if not List.Is_Null then
         Iterate (List.Value, Process);
      end if;
   end Iterate;

   --  ------------------------------
   --  Returns True if the list reference is empty.
   --  ------------------------------
   function Is_Empty (List : in Node_List_Ref) return Boolean is
   begin
      return List.Is_Null;
   end Is_Empty;

   --  ------------------------------
   --  Get the number of nodes in the list.
   --  ------------------------------
   function Length (List : in Node_List_Ref) return Natural is
   begin
      if List.Is_Null then
         return 0;
      else
         return List.Value.Length;
      end if;
   end Length;

end Wiki.Nodes.Lists;

Refactor Node_List and references to use Ada Util general references


-----------------------------------------------------------------------
--  gen-artifacts-yaml -- Query artifact for Code Generator
--  Copyright (C) 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Exceptions;

with Util.Strings;

with Text;
with Yaml.Source.File;
with Yaml.Parser;

with Gen.Configs;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;
with Gen.Model.Operations;

with Util.Log.Loggers;
with Util.Encoders.HMAC.SHA1;
with Util.Stacks;

use Yaml;

package body Gen.Artifacts.Yaml is

   use Ada.Strings.Unbounded;
   use Gen.Model;
   use Gen.Model.Tables;
   use Gen.Model.Queries;
   use Gen.Configs;

   use Util.Log;

   use type Text.Reference;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Yaml");

   type State_Type is (IN_ROOT,
                       IN_TABLE,
                       IN_COLUMNS,
                       IN_COLUMN,
                       IN_UNKOWN);

   type Node_Info is record
      State    : State_Type;
      Name     : Text.Reference;
      Has_Name : Boolean := False;
      Table    : Gen.Model.Tables.Table_Definition_Access;
      Col      : Gen.Model.Tables.Column_Definition_Access;
   end record;

   type Node_Info_Access is access all Node_Info;

   package Node_Stack is new Util.Stacks (Element_Type        => Node_Info,
                                          Element_Type_Access => Node_Info_Access);

   procedure Read_Scalar (Node  : in Node_Info_Access;
                          Name  : in String;
                          Value : in String) is
   begin
      case Node.State is
         when IN_TABLE =>
            if Node.Table = null then
               return;
            end if;

            Log.Debug ("Set table {0} attribute {1}={2}", Node.Table.Name, Name, Value);
            if Name = "table" then
               Node.Table.Table_Name := To_Unbounded_String (Value);
            end if;

         when IN_COLUMN =>
            if Node.Col = null then
               return;
            end if;

            Log.Debug ("Set table column {0} attribute {1}={2}", Node.Col.Name, Name, Value);
            if Name = "type" then
               Node.Col.Set_Type (Value);
            elsif Name = "length" then
               Node.Col.Sql_Length := Natural'Value (Value);
            elsif Name = "column" then
               Node.Col.Sql_Name := To_Unbounded_String (Value);
            elsif Name = "unique" then
               Node.Col.Unique := Value = "true" or Value = "yes";
            elsif Name = "nullable" then
               null;
            end if;

         when others =>
            Log.Error ("Scalar {0}: {1} not handled", Name, Value);
      end case;
   end Read_Scalar;

   procedure Process_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                              Stack : in out Node_Stack.Stack) is
      Node     : Node_Info_Access;
      New_Node : Node_Info_Access;
   begin
      Node := Node_Stack.Current (Stack);
      if Node.Has_Name then
         Node.Has_Name := False;
         case Node.State is
            when IN_ROOT =>
               Node_Stack.Push (Stack);
               New_Node := Node_Stack.Current (Stack);
               New_Node.Table := Gen.Model.Tables.Create_Table (To_Unbounded_String (Node.Name & ""));
               New_Node.State := IN_TABLE;
               Model.Register_Table (New_Node.Table);

            when IN_TABLE =>
               if Node.Name = "fields" or Node.Name = "properties" then
                  Node_Stack.Push (Stack);
                  New_Node := Node_Stack.Current (Stack);
                  New_Node.Table := Node.Table;
                  New_Node.State := IN_COLUMNS;
               end if;

            when IN_COLUMNS =>
               Node.Table.Add_Column (To_Unbounded_String (Node.Name & ""), Node.Col);
               Node_Stack.Push (Stack);
               New_Node := Node_Stack.Current (Stack);
               New_Node.Table := Node.Table;
               New_Node.State := IN_COLUMN;

            when others =>
               Node_Stack.Push (Stack);
               New_Node := Node_Stack.Current (Stack);
               New_Node.State := IN_UNKOWN;

         end case;
      end if;
   end Process_Mapping;

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler       : in out Artifact;
                         File          : in String;
                         Model         : in out Gen.Model.Packages.Model_Definition;
                         Context       : in out Generator'Class;
                         Is_Predefined : in Boolean := False) is
      Input : Source.Pointer;
      P     : Parser.Instance;
      Cur   : Event;
      Stack : Node_Stack.Stack;
      Node  : Node_Info_Access;
      Loc   : Mark;
   begin
      Log.Info ("Reading YAML file {0}", File);

      Input := Source.File.As_Source (File);
      P.Set_Input (Input);
      loop
         Cur := P.Next;
         exit when Cur.Kind = Stream_End;
         case Cur.Kind is
            when Stream_Start | Document_Start =>
               Node_Stack.Push (Stack);

            when Stream_End | Document_End =>
               Node_Stack.Pop (Stack);

            when Alias =>
               null;

            when Scalar =>
               Node := Node_Stack.Current (Stack);
               if Node.Has_Name then
                  Read_Scalar (Node, Node.Name & "", Cur.Content & "");
                  Node.Has_Name := False;
               else
                  Node.Name := Cur.Content;
                  Node.Has_Name := True;
               end if;

            when Sequence_Start =>
               Node_Stack.Push (Stack);

            when Sequence_End =>
               Node_Stack.Pop (Stack);

            when Mapping_Start =>
               Process_Mapping (Model, Stack);

            when Mapping_End =>
               Node_Stack.Pop (Stack);

            when Annotation_Start =>
               null;

            when Annotation_End =>
               null;

         end case;
      end loop;

   exception
      when E : others =>
         Loc := P.Current_Lexer_Token_Start;
         Context.Error ("{0}: {1}", Util.Strings.Image (Loc.Line) & ":"
                        & Util.Strings.Image (Loc.Column) & ": ",
                        Ada.Exceptions.Exception_Message (E));
   end Read_Model;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Debug ("Preparing the model for query");

      if Model.Has_Packages then
         Context.Add_Generation (Name => GEN_PACKAGE_SPEC, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
         Context.Add_Generation (Name => GEN_PACKAGE_BODY, Mode => ITERATION_PACKAGE,
                                 Mapping => Gen.Model.Mappings.ADA_MAPPING);
      end if;
   end Prepare;

end Gen.Artifacts.Yaml;

Read a YAML model files and configure the model tables with it


-----------------------------------------------------------------------
--  wiki-render-wiki -- Wiki to Wiki renderer
--  Copyright (C) 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;

with Util.Strings;

with Wiki.Documents;
with Wiki.Attributes;
with Wiki.Writers;
with Wiki.Parsers;

--  == Wiki Renderer ==
--  The <tt>Wiki_Renderer</tt> allows to render a wiki document into another wiki content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Wiki is

   use Standard.Wiki.Attributes;
   use Ada.Strings.Wide_Wide_Unbounded;

   --  ------------------------------
   --  Wiki to HTML writer
   --  ------------------------------
   type Wiki_Renderer is new Standard.Wiki.Documents.Document_Reader with private;

   --  Set the output writer.
   procedure Set_Writer (Document : in out Wiki_Renderer;
                         Writer   : in Writers.Writer_Type_Access;
                         Format   : in Parsers.Wiki_Syntax_Type);

   --  Add a section header in the document.
   overriding
   procedure Add_Header (Document : in out Wiki_Renderer;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive);

   --  Add a line break (
).
   overriding
   procedure Add_Line_Break (Document : in out Wiki_Renderer);

   --  Add a paragraph (
).  Close the previous paragraph if any.
   --  The paragraph must be closed at the next paragraph or next header.
   overriding
   procedure Add_Paragraph (Document : in out Wiki_Renderer);

   --  Add a blockquote (
).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   overriding
   procedure Add_Blockquote (Document : in out Wiki_Renderer;
                             Level    : in Natural);

   --  Add a list item (
).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   overriding
   procedure Add_List_Item (Document : in out Wiki_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add an horizontal rule (
).
   overriding
   procedure Add_Horizontal_Rule (Document : in out Wiki_Renderer);

   --  Add a link.
   overriding
   procedure Add_Link (Document : in out Wiki_Renderer;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String);

   --  Add an image.
   overriding
   procedure Add_Image (Document    : in out Wiki_Renderer;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String);

   --  Add a quote.
   overriding
   procedure Add_Quote (Document : in out Wiki_Renderer;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block with the given format.
   overriding
   procedure Add_Text (Document : in out Wiki_Renderer;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Documents.Format_Map);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Wiki_Renderer;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   overriding
   procedure Start_Element (Document   : in out Wiki_Renderer;
                            Name       : in Unbounded_Wide_Wide_String;
                            Attributes : in Attribute_List_Type);

   overriding
   procedure End_Element (Document : in out Wiki_Renderer;
                          Name     : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Wiki_Renderer);

private

   type Wide_String_Access is access constant Wide_Wide_String;

   type Wiki_Tag_Type is (Bold_Start, Bold_End, Italic_Start, Italic_End,
                          Underline_Start, Underline_End,
                          Header_Start, Header_End,
                          Line_Break,
                          Blockquote_Start, Blockquote_End);

   type Wiki_Tag_Array is array (Wiki_Tag_Type) of Wide_String_Access;

   --  Emit a new line.
   procedure New_Line (Document : in out Wiki_Renderer);

   procedure Close_Paragraph (Document : in out Wiki_Renderer);
   procedure Open_Paragraph (Document : in out Wiki_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   EMPTY_TAG : aliased constant Wide_Wide_String := "";

   type Wiki_Renderer is new Documents.Document_Reader with record
      Writer         : Writers.Writer_Type_Access := null;
      Syntax         : Parsers.Wiki_Syntax_Type := Parsers.SYNTAX_CREOLE;
      Format         : Documents.Format_Map := (others => False);
      Tags           : Wiki_Tag_Array := (others => EMPTY_TAG'Access);
      Has_Paragraph  : Boolean := False;
      Has_Item       : Boolean := False;
      Need_Paragraph : Boolean := False;
      Empty_Line     : Boolean := True;
      Current_Level  : Natural := 0;
      Quote_Level    : Natural := 0;
   end record;

end Wiki.Render.Wiki;

Define the Wiki renderer type to render the result in Wiki text


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--   A S I S . D A T A _ D E C O M P O S I T I O N . E X T E N S I O N S    --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2008, 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).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains queries yielding various representation information
--  which may be useful for ASIS applications, and which can not be obtained
--  through the Asis.Data_Decomposition package as defined by the ASIS
--  Standard.

package Asis.Data_Decomposition.Extensions is

   generic
      type Constrained_Subtype is private;
   function Portable_Data_Value
     (Value : Constrained_Subtype)
      return Portable_Data;
   --  This is the inverse function for
   --  Asis.Data_Decomposition.Portable_Constrained_Subtype. Instantiated with
   --  an appropriate scalar type, (e.g., System.Integer, can be used to
   --  convert value to a data stream that can be used by ASIS Data
   --  Decomposition queries, in particular, for passing as an actual for the
   --  Value parameter of
   --  Asis.Data_Decomposition.Construct_Artificial_Data_Stream.
   --
   --  Instantiated with a record type, can be used to convert a value to a
   --  data stream that can be analyzed by ASIS Data Decomposition queries.

   function Component_Name_Definition
     (Component : Record_Component)
      return      Asis.Declaration;
   --  For the argument Compononent, returns the corresponding
   --  A_Defining_Identified Element.
   --  Asis.Data_Decomposition.Component_Declaration query can not be used to
   --  determine the name of the component in case if two or more record
   --  components are defined by the same component declaration or discriminant
   --  specification, that's why this query may be needed.
   --
   --  All non-Nil component values are appropriate.
   --
   --  Returns Defining_Name_Kinds:
   --       A_Defining_Identifier

   ----------------------------
   -- Static type attributes --
   ----------------------------

   --  Queries defined in this section returns static representation
   --  attributes of types and subtypes. Some, but not all of the attributes
   --  defined in RM 95 which return representation information about types
   --  and subtypes and which are not functions are mapped onto
   --  Asis.Data_Decomposition.Extensions queries.

   --  --|AN Application Note:
   --
   --  In contrast to Asis.Data_Decomposition queries which operates on type
   --  definitions, these queries operates on type and subtype defining names.
   --  The reason is that type and its subtypes may have different values of
   --  the same representation attribute, and this difference may be
   --  important for application.

   --------------------------------------------------------
   -- Floating Point Types and Decimal Fixed Point Types --
   --------------------------------------------------------

   function Digits_Value
     (Floating_Point_Subtype : Asis.Element)
      return                   ASIS_Natural;
   --  Provided that Floating_Point_Subtype is the defining name of some
   --  floating point or decimal fixed point type or subtype (including types
   --  derived from floating point or decimal fixed point types), this
   --  function returns the requested decimal precision for this type or
   --  subtype, as defined in RM 95, 3.5.8(2), 3.5.10(7)
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some floating
   --                            point or decimal fixed point type
   --                            or subtype

   -----------------------------------------------------
   -- Fixed Point Types and Decimal Fixed Point Types --
   -----------------------------------------------------

   --  --|AN Application Note:
   --
   --  For fixed point types, it is important to return the precise values of
   --  'small' and 'delta'. The corresponding Ada attributes 'Small and 'Delta
   --  are defined in RM95 as being of universal_real type. But in this unit,
   --  we can not use universal_real as a return type of a query, and using
   --  any explicitly defined real type can not guarantee that the exact
   --  values of 'small' and 'delta' will be returned by the corresponding
   --  queries, since these values have arbitrary exact precision.
   --
   --  To represent the value of universal_real type, the Small_Value
   --  and Delta_Value functions return a pair of integers representing
   --  the normalized fraction with integer numerator and denominator
   --  ("normalized means that the fraction is reduced to lowest terms),
   --  or alternatively a string is returned that contains the fraction
   --  represented in this manner. The latter form is the only one that
   --  can be used if the numerator or denominator is outside the range
   --  of ASIS_Integer.

   type Fraction is record
      Num   : ASIS_Integer;
      Denum : ASIS_Positive;
   end record;

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String;
   --  Provided that Fixed_Point_Subtype is the defining name of some
   --  fixed point type or subtype (including types derived from fixed
   --  point types), this function returns the string image of 'small' of
   --  this type or subtype, as defined in RM 95, 3.5.10(2) as a string
   --  value representing a fraction (numerator / denominator), with no
   --  spaces, and both numerator and denominator represented in decimal.
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some fixed point
   --                            or decimal fixed point type or subtype

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                Fraction;
   --  Provided that Fixed_Point_Subtype is the defining name of some
   --  fixed point type or subtype (including types derived from fixed
   --  point types), this function returns the fraction representation of
   --  'small' of this type or subtype, as defined in RM 95, 3.5.10(2)
   --  ASIS_Failed is raised and the corresponding Diagnosis tring is set
   --  if the numerator or denominator is outside the representable range.
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some fixed point
   --                            or decimal fixed point type or subtype

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String;
   --  Provided that Fixed_Point_Subtype is the defining name of some
   --  fixed point type or subtype (including types derived from fixed
   --  point types), this function returns the string image of 'delta' of
   --  this type or subtype, as defined in RM 95, 3.5.10(2) as a string
   --  value representing a fraction (numerator / denominator), with no
   --  spaces, and both numerator and denominator represented in decimal.
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some fixed point
   --                            or decimal fixed point type or subtype

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return               Fraction;
   --  Provided that Fixed_Point_Subtype is the defining name of some
   --  fixed point type or subtype (including types derived from fixed
   --  point types), this function returns the fraction representation of
   --  'delta' of this type or subtype, as defined in RM 95, 3.5.10(3)
   --  ASIS_Failed is raised and the corresponding Diagnosis tring is set
   --  if the numerator or denominator is outside the representable range.
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some fixed point
   --                            or decimal fixed point type or subtype

   ----------------------
   -- Other Attributes --
   ----------------------

   --  The current version of Asis.Data_Decomposition.Extensions does not
   --  provide queries for the 'Fore or 'Aft attributes of fixed point types.

   -------------------------------
   -- Decimal Fixed Point Types --
   -------------------------------

   function Scale_Value
     (Desimal_Fixed_Point_Subtype : Asis.Element)
      return                        ASIS_Natural;
   --  Provided that Desimal_Fixed_Point_Subtype is the defining name of some
   --  decimal fixed point type or subtype (including types derived from
   --  decimal fixed point types), this function returns the scale of
   --  this type or subtype, as defined in RM 95 3.5.10(11).
   --
   --  Appropriate Defining_Name_Kinds
   --     A_Defining_Identifier, provided that it defines some decimal fixed
   --                            point type or subtype

end Asis.Data_Decomposition.Extensions;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  util-beans-objects-iterators -- Iterators for objects
--  Copyright (C) 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Util.Beans.Basic;

package body Util.Beans.Objects.Iterators is

   --  ------------------------------
   --  Returns True if the iterator provides a key for each element.
   --  ------------------------------
   function Has_Key (Iter : in Iterator) return Boolean is
   begin
      return Iter.Iter /= null and then Iter.Iter.all in Proxy_Map_Iterator'Class;
   end Has_Key;

   --  ------------------------------
   --  Returns True if the iterator has an element.
   --  ------------------------------
   function Has_Element (Iter : in Iterator) return Boolean is
   begin
      return Iter.Iter /= null and then Iter.Iter.Has_Element;
   end Has_Element;

   --  ------------------------------
   --  Returns the current iterator element or Null_Object if it is empty.
   --  ------------------------------
   function Element (Iter : in Iterator) return Object is
   begin
      if Iter.Iter = null then
         return Null_Object;
      else
         return Object (Iter.Iter.Element);
      end if;
   end Element;

   --  ------------------------------
   --  Returns the key associated with the current element.
   --  ------------------------------
   function Key (Iter : in Iterator) return String is
   begin
      if Iter.Iter = null then
         return "";
      elsif not (Iter.Iter.all in Proxy_Map_Iterator'Class) then
         return "";
      else
         return Proxy_Map_Iterator'Class (Iter.Iter.all).Key;
      end if;
   end Key;

   --  ------------------------------
   --  Move the iterator to the next element.
   --  ------------------------------
   procedure Next (Iter : in out Iterator) is
   begin
      if Iter.Iter /= null then
         Iter.Iter.Next;
      end if;
   end Next;

   --  ------------------------------
   --  Move the iterator to the previous element.
   --  ------------------------------
   procedure Previous (Iter : in out Iterator) is
   begin
      if Iter.Iter /= null then
         Iter.Iter.Previous;
      end if;
   end Previous;

   overriding
   procedure Adjust (Iter : in out Iterator) is
   begin
      if Iter.Iter /= null then
         Util.Concurrent.Counters.Increment (Iter.Iter.Ref_Counter);
      end if;
   end Adjust;

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

   overriding
   procedure Finalize (Iter : in out Iterator) is
      Release : Boolean;
   begin
      if Iter.Iter /= null then
         Util.Concurrent.Counters.Decrement (Iter.Iter.Ref_Counter, Release);
         if Release then
            Free (Iter.Iter);
         else
            Iter.Iter := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Create an iterator to iterate from the first element.
   --  ------------------------------
   function First (Item : in Object) return Iterator is
      Iter : Iterator;
   begin
      if Item.V.Of_Type /= TYPE_BEAN then
         return Iter;
      end if;
      if Item.V.Proxy = null then
         return Iter;
      end if;
      declare
         Proxy       : constant Bean_Proxy_Access := Item.V.Proxy;
         List        : Iterator_Bean_Access;
      begin
         if not (Bean_Proxy (Proxy.all).Bean.all in Iterator_Bean'Class) then
            return Iter;
         end if;
         List := Iterator_Bean'Class (Bean_Proxy (Proxy.all).Bean.all)'Unchecked_Access;
         Iter.Iter := List.First;
         if Iter.Iter /= null then
            Util.Concurrent.Counters.Increment (Iter.Iter.Ref_Counter);
            Iter.Iter.Proxy := Proxy;
            Util.Concurrent.Counters.Increment (Proxy.Ref_Counter);
         end if;
      end;
      return Iter;
   end First;

   --  ------------------------------
   --  Create an iterator to iterate from the last element.
   --  ------------------------------
   function Last (Item : in Object) return Iterator is
      Iter : Iterator;
   begin
      if Item.V.Of_Type /= TYPE_BEAN then
         return Iter;
      end if;
      if Item.V.Proxy = null then
         return Iter;
      end if;
      declare
         Proxy       : constant Bean_Proxy_Access := Item.V.Proxy;
         List        : Iterator_Bean_Access;
      begin
         if not (Bean_Proxy (Proxy.all).Bean.all in Iterator_Bean'Class) then
            return Iter;
         end if;
         List := Iterator_Bean'Class (Bean_Proxy (Proxy.all).Bean.all)'Unchecked_Access;
         Iter.Iter := List.Last;
         if Iter.Iter /= null then
            Util.Concurrent.Counters.Increment (Iter.Iter.Ref_Counter);
            Iter.Iter.Proxy := Proxy;
            Util.Concurrent.Counters.Increment (Proxy.Ref_Counter);
         end if;
      end;
      return Iter;
   end Last;

   package body Iter is

      overriding
      function First (Object : in Forward_Iterator) return Iterator is
      begin
         return Object.Iter;
      end First;

      overriding
      function Next (Object : in Forward_Iterator;
                     Pos    : in Iterator) return Iterator is
         Result : Iterator := Pos;
      begin
         Next (Result);
         return Result;
      end Next;

   end Iter;

   function Iterate (Item : in Object) return
     Object_Iterator_Interfaces.Forward_Iterator'Class is
   begin
      return Result : Iter.Forward_Iterator do
         Result.Iter := First (Item);
      end return;
   end Iterate;

   overriding
   procedure Finalize (Proxy : in out Proxy_Iterator) is
      Release : Boolean;
   begin
      if Proxy.Proxy /= null then
         Util.Concurrent.Counters.Decrement (Proxy.Proxy.Ref_Counter, Release);
         if Release then
            Free (Proxy.Proxy);
         else
            Proxy.Proxy := null;
         end if;
      end if;
   end Finalize;

   function Get_Bean (Iter : in Proxy_Iterator'Class) return T_Access is
   begin
      if Iter.Proxy = null then
         return null;
      end if;
      if not (Bean_Proxy (Iter.Proxy.all).Bean.all in T'Class) then
         return null;
      end if;
      return T'Class (Bean_Proxy (Iter.Proxy.all).Bean.all)'Unchecked_Access;
   end Get_Bean;

end Util.Beans.Objects.Iterators;

Implement the Iterators operations

Implement the Iterators operations


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                           A 4 G . A _ E L I S T S                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2007, 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.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

--  This is the modification of the GNAT Elists package. See spec for the
--  description of the modifications.

with A4G.A_Debug;  use A4G.A_Debug;

with Output;       use Output;

package body A4G.A_Elists is

   ----------------------
   -- Add_To_Elmt_List --
   ----------------------

   procedure Add_To_Elmt_List (Unit : Unit_Id; List : in out Elist_Id) is
   begin
      if No (List) then
         List := New_Elmt_List;
         Append_Elmt (Unit, List);
      elsif not In_Elmt_List (Unit, List) then
         Append_Elmt (Unit, List);
      end if;
   end Add_To_Elmt_List;

   -----------------
   -- Append_Elmt --
   -----------------

   procedure Append_Elmt (Unit : Unit_Id; To : Elist_Id) is
      L : constant Elmt_Id := Elists.Table (To).Last;

   begin
      Elmts.Increment_Last;
      Elmts.Table (Elmts.Last).Unit := Unit;
      Elmts.Table (Elmts.Last).Next := Union_Id (To);

      if L = No_Elmt then
         Elists.Table (To).First := Elmts.Last;
      else
         Elmts.Table (L).Next := Union_Id (Elmts.Last);
      end if;

      Elists.Table (To).Last  := Elmts.Last;

      if Debug_Flag_N then
         Write_Str ("Append new element Elmt_Id = ");
         Write_Int (Int (Elmts.Last));
         Write_Str (" to list Elist_Id = ");
         Write_Int (Int (To));
         Write_Str (" referencing Unit_Id = ");
         Write_Int (Int (Unit));
         Write_Eol;
      end if;
   end Append_Elmt;

   ------------------
   -- Prepend_Elmt --
   ------------------

   procedure Prepend_Elmt (Unit : Unit_Id; To : Elist_Id) is
      F : constant Elmt_Id := Elists.Table (To).First;

   begin
      Elmts.Increment_Last;
      Elmts.Table (Elmts.Last).Unit := Unit;

      if F = No_Elmt then
         Elists.Table (To).Last := Elmts.Last;
         Elmts.Table (Elmts.Last).Next := Union_Id (To);
      else
         Elmts.Table (Elmts.Last).Next := Union_Id (F);
      end if;

      Elists.Table (To).First  := Elmts.Last;

   end Prepend_Elmt;

   -----------------------
   -- Insert_Elmt_After --
   -----------------------

   procedure Insert_Elmt_After (Unit : Unit_Id; Elmt : Elmt_Id) is
      N : constant Union_Id := Elmts.Table (Elmt).Next;

   begin

      pragma Assert (Elmt /= No_Elmt);

      Elmts.Increment_Last;
      Elmts.Table (Elmts.Last).Unit := Unit;
      Elmts.Table (Elmts.Last).Next := N;

      Elmts.Table (Elmt).Next := Union_Id (Elmts.Last);

      if N in Elist_Range then
         Elists.Table (Elist_Id (N)).Last := Elmts.Last;
      end if;
   end Insert_Elmt_After;

   -------------
   -- Belongs --
   -------------

   function Belongs (List1 : Elist_Id; List2 : Elist_Id) return Boolean is
      Curr_Elmt : Elmt_Id;
   begin
      if No (List1) or else Is_Empty_Elmt_List (List1) then
         return True;
      end if;

      Curr_Elmt := First_Elmt (List1);

      while Present (Curr_Elmt) loop
         if not In_Elmt_List (Unit (Curr_Elmt), List2) then
            return False;
         end if;
         Curr_Elmt := Next_Elmt (Curr_Elmt);
      end loop;

      return True;

   end Belongs;

   ----------------
   -- First_Elmt --
   ----------------

   function First_Elmt (List : Elist_Id) return Elmt_Id is
   begin
      pragma Assert (List > Elist_Low_Bound);
      return Elists.Table (List).First;
   end First_Elmt;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Elists.Init;
      Elmts.Init;
   end Initialize;

   ------------------
   -- In_Elmt_List --
   ------------------

   function In_Elmt_List (U : Unit_Id; List : Elist_Id) return Boolean is
      Curr_Elmt : Elmt_Id;
   begin
      if No (List) or else Is_Empty_Elmt_List (List) then
         return False;
      end if;

      Curr_Elmt := First_Elmt (List);
      while Present (Curr_Elmt) loop
         if U = Unit (Curr_Elmt) then
            return True;
         end if;
         Curr_Elmt := Next_Elmt (Curr_Elmt);
      end loop;

      return False;

   end In_Elmt_List;

   ---------------
   -- Intersect --
   ---------------

   function Intersect (List1 : Elist_Id; List2 : Elist_Id) return Boolean is
      Curr_Elmt : Elmt_Id;
   begin
      if No (List1) or else  No (List2) or else
         Is_Empty_Elmt_List (List1) or else
         Is_Empty_Elmt_List (List2)
      then
         return False;
      else
         Curr_Elmt := First_Elmt (List1);

         while Present (Curr_Elmt) loop
            if In_Elmt_List (Unit (Curr_Elmt), List2) then
               return True;
            end if;
            Curr_Elmt := Next_Elmt (Curr_Elmt);
         end loop;

         return False;
      end if;
   end Intersect;

   ------------------------
   -- Is_Empty_Elmt_List --
   ------------------------

   function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is
   begin
      return Elists.Table (List).First = No_Elmt;
   end Is_Empty_Elmt_List;

   -------------------
   -- Last_Elist_Id --
   -------------------

   function Last_Elist_Id return Elist_Id is
   begin
      return Elists.Last;
   end Last_Elist_Id;

   ---------------
   -- Last_Elmt --
   ---------------

   function Last_Elmt (List : Elist_Id) return Elmt_Id is
   begin
      return Elists.Table (List).Last;
   end Last_Elmt;

   ------------------
   -- Last_Elmt_Id --
   ------------------

   function Last_Elmt_Id return Elmt_Id is
   begin
      return Elmts.Last;
   end Last_Elmt_Id;

   -----------------
   -- List_Length --
   -----------------

   function List_Length (List : Elist_Id) return Natural is
      Result : Natural := 0;
      Elem   : Elmt_Id;
   begin
      Elem := First_Elmt (List);

      while Present (Elem) loop
         Result := Result + 1;
         Elem   := Next_Elmt (Elem);
      end loop;

      return Result;
   end List_Length;

   ---------------
   -- Move_List --
   ---------------

   procedure Move_List
     (List_From :        Elist_Id;
      List_To   : in out Elist_Id)
   is
   begin
      if No (List_To) then
         List_To := New_Elmt_List;
      end if;

      if No (List_From) or else Is_Empty_Elmt_List (List_From) then
         return;
      end if;

      --  if we are here, we have to move elements...

      if Is_Empty_Elmt_List (List_To) then

         Elists.Table (List_To).Last  := Elists.Table (List_From).Last;
         Elmts.Table (Elists.Table (List_From).Last).Next :=
            Union_Id (List_To);

      else
         Elmts.Table (Elists.Table (List_From).Last).Next :=
            Elmts.Table (Elists.Table (List_To).First).Next;
      end if;

      Elists.Table (List_To).First := Elists.Table (List_From).First;

      Elists.Table (List_From).First := No_Elmt;
      Elists.Table (List_From).Last  := No_Elmt;

   end Move_List;

   -------------------
   -- New_Elmt_List --
   -------------------

   function New_Elmt_List return Elist_Id is
   begin
      Elists.Increment_Last;
      Elists.Table (Elists.Last).First := No_Elmt;
      Elists.Table (Elists.Last).Last  := No_Elmt;

      if Debug_Flag_N then
         Write_Str ("Allocate new element list, returned ID = ");
         Write_Int (Int (Elists.Last));
         Write_Eol;
      end if;

      return Elists.Last;
   end New_Elmt_List;

   ---------------
   -- Next_Elmt --
   ---------------

   function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is
      N : constant Union_Id := Elmts.Table (Elmt).Next;

   begin
      if N in Elist_Range then
         return No_Elmt;
      else
         return Elmt_Id (N);
      end if;
   end Next_Elmt;

   --------
   -- No --
   --------

   function No (List : Elist_Id) return Boolean is
   begin
      return List = No_Elist;
   end No;

   function No (Elmt : Elmt_Id) return Boolean is
   begin
      return Elmt = No_Elmt;
   end No;

   -----------
   -- Unit --
   -----------

   function Unit (Elmt : Elmt_Id) return Unit_Id is
   begin
      if Elmt = No_Elmt then
         return Nil_Unit;
      else
         return Elmts.Table (Elmt).Unit;
      end if;
   end Unit;

   ----------------
   -- Num_Elists --
   ----------------

   function Num_Elists return Nat is
   begin
      return Int (Elmts.Last) - Int (Elmts.First) + 1;
   end Num_Elists;

   -------------
   -- Present --
   -------------

   function Present (List : Elist_Id) return Boolean is
   begin
      return List /= No_Elist;
   end Present;

   function Present (Elmt : Elmt_Id) return Boolean is
   begin
      return Elmt /= No_Elmt;
   end Present;

   ----------------
   -- Print_List --
   ----------------

   procedure Print_List (List : Elist_Id) is
      Curr_Elmt : Elmt_Id;
      Counter   : Int := 1;
   begin
      if No (List) then
         if Debug_Flag_N then
            Write_Str ("   There is no list here");
            Write_Eol;
         end if;
         return;
      end if;

      if Is_Empty_Elmt_List (List) then
         if Debug_Flag_N then
            Write_Str ("   The list is empty");
            Write_Eol;
         end if;
         return;
      end if;

      if Debug_Flag_N then
         Write_Str ("List contains the following Ids:");
         Write_Eol;
      end if;

      Curr_Elmt := First_Elmt (List);
      while Present (Curr_Elmt) loop
         if Debug_Flag_N then
            Write_Str ("   Element number ");
            Write_Int (Counter);
            Write_Str (" is ");
            Write_Int (Int (Unit (Curr_Elmt)));
            Write_Eol;
         end if;
         Curr_Elmt := Next_Elmt (Curr_Elmt);
         Counter   := Counter + 1;
      end loop;

   end Print_List;

   -----------------
   -- Remove_Elmt --
   -----------------

   procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is
      Nxt : Elmt_Id;
      Prv : Elmt_Id;

   begin
      Nxt := Elists.Table (List).First;

      --  Case of removing only element in the list

      if Elmts.Table (Nxt).Next in Elist_Range then

         pragma Assert (Nxt = Elmt);

         Elists.Table (List).First := No_Elmt;
         Elists.Table (List).Last  := No_Elmt;

      --  Case of removing the first element in the list

      elsif Nxt = Elmt then
         Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next);

      --  Case of removing second or later element in the list

      else
         loop
            Prv := Nxt;
            Nxt := Elmt_Id (Elmts.Table (Prv).Next);
            exit when Nxt = Elmt
              or else Elmts.Table (Nxt).Next in Elist_Range;
         end loop;

         pragma Assert (Nxt = Elmt);

         Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next;

         if Elmts.Table (Prv).Next in Elist_Range then
            Elists.Table (List).Last := Prv;
         end if;
      end if;
   end Remove_Elmt;

   ----------------------
   -- Remove_Last_Elmt --
   ----------------------

   procedure Remove_Last_Elmt (List : Elist_Id) is
      Nxt : Elmt_Id;
      Prv : Elmt_Id;

   begin
      Nxt := Elists.Table (List).First;

      --  Case of removing only element in the list

      if Elmts.Table (Nxt).Next in Elist_Range then
         Elists.Table (List).First := No_Elmt;
         Elists.Table (List).Last  := No_Elmt;

      --  Case of at least two elements in list

      else
         loop
            Prv := Nxt;
            Nxt := Elmt_Id (Elmts.Table (Prv).Next);
            exit when Elmts.Table (Nxt).Next in Elist_Range;
         end loop;

         Elmts.Table (Prv).Next   := Elmts.Table (Nxt).Next;
         Elists.Table (List).Last := Prv;
      end if;
   end Remove_Last_Elmt;

   ------------------
   -- Replace_Elmt --
   ------------------

   procedure Replace_Elmt (Elmt : Elmt_Id; New_Unit : Unit_Id) is
   begin
      Elmts.Table (Elmt).Unit := New_Unit;
   end Replace_Elmt;

end A4G.A_Elists;

Add the ASIS file $i

Add the ASIS file $i