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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

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

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

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

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

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication 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);

   --  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;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

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

end Security.Auth;

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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  @include security-auth-openid.ads
--  @include security-auth-oauth.ads
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

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

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

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

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

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication 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);

   --  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;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

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

end Security.Auth;

Add some documentation

Add some documentation


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

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_CONDITION, N_THREAD);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a new expression node.
   function Create (Kindx : in Kind_Type;
                    Expr : in Expression_Type) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node    : in Expression_Type;
                         Context : in Context_Type) return Boolean;

private

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name : Ada.Strings.Unbounded.Unbounded_String;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_THREAD =>
            Thread : MAT.Types.Target_Thread_Ref;

         when others =>
            null;
      end case;
   end record;

   function Is_Selected (Node    : in Node_Type;
                         Context : in Context_Type) return Boolean;

   type Expression_Type is tagged record
      Node : Node_Type_Access;
   end record;

end MAT.Expressions;

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

private with Util.Concurrent.Counters;

with MAT.Types;
with MAT.Memory;
package MAT.Expressions is

   type Context_Type is record
      Addr       : MAT.Types.Target_Addr;
      Allocation : MAT.Memory.Allocation;
   end record;

   type Kind_Type is (N_NOT, N_OR, N_AND, N_TRUE, N_FALSE,
                      N_IN_FILE, N_IN_FILE_DIRECT,
                      N_CALL_ADDR, N_CALL_ADDR_DIRECT,
                      N_IN_FUNC, N_IN_FUNC_DIRECT,
                      N_RANGE_SIZE, N_RANGE_ADDR,
                      N_CONDITION, N_THREAD);

   type Expression_Type is tagged private;

   --  Create a NOT expression node.
   function Create_Not (Expr : in Expression_Type) return Expression_Type;

   --  Create a AND expression node.
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type;

   --  Create a OR expression node.
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type;

   --  Create a new expression node.
   function Create (Kindx : in Kind_Type;
                    Expr : in Expression_Type) return Expression_Type;

   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   function Is_Selected (Node    : in Expression_Type;
                         Context : in Context_Type) return Boolean;

private

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

   type Node_Type (Kind : Kind_Type) is record
      Ref_Counter : Util.Concurrent.Counters.Counter;
      case Kind is
         when N_NOT =>
            Expr : Node_Type_Access;

         when N_OR | N_AND =>
            Left, Right : Node_Type_Access;

         when N_IN_FILE | N_IN_FILE_DIRECT | N_IN_FUNC | N_IN_FUNC_DIRECT =>
            Name : Ada.Strings.Unbounded.Unbounded_String;

         when N_RANGE_SIZE =>
            Min_Size : MAT.Types.Target_Size;
            Max_Size : MAT.Types.Target_Size;

         when N_RANGE_ADDR | N_CALL_ADDR | N_CALL_ADDR_DIRECT =>
            Min_Addr : MAT.Types.Target_Addr;
            Max_Addr : MAT.Types.Target_Addr;

         when N_THREAD =>
            Thread : MAT.Types.Target_Thread_Ref;

         when others =>
            null;
      end case;
   end record;

   function Is_Selected (Node    : in Node_Type;
                         Context : in Context_Type) return Boolean;

   type Expression_Type is tagged record
      Node : Node_Type_Access;
   end record;

end MAT.Expressions;

Define the Create_Or operation

Define the Create_Or operation


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

with Util.Systems.Os;
with Interfaces.C;
private package Util.Processes.Os is

   use Util.Systems.Os;

   SHELL : constant String := "";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   type System_Process is new Util.Processes.System_Process with record
      Process_Info : aliased Util.Systems.Os.PROCESS_INFORMATION;
      Command      : Wchar_Ptr := null;
      Pos          : Interfaces.C.size_t := 0;
   end record;

   --  Wait for the process to exit.
   overriding
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration);

   --  Spawn a new process.
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15);

   --  Append the argument to the process argument list.
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String);

   --  Set the process input, output and error streams to redirect and use specified files.
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean);

   --  Deletes the storage held by the system process.
   overriding
   procedure Finalize (Sys : in out System_Process);

   --  Build the output pipe redirection to read the process output.
   procedure Build_Output_Pipe (Proc : in out Process'Class;
                                Into : in out Startup_Info);

   --  Build the input pipe redirection to write the process standard input.
   procedure Build_Input_Pipe (Proc : in out Process'Class;
                               Into : in out Startup_Info);

private

   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   function Create_Stream (File : in Util.Streams.Raw.File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access;

end Util.Processes.Os;

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

with Util.Systems.Os;
with Interfaces.C;
private package Util.Processes.Os is

   use Util.Systems.Os;

   SHELL : constant String := "";

   type Wchar_Ptr is access all Interfaces.C.wchar_array;

   type System_Process is new Util.Processes.System_Process with record
      Process_Info : aliased Util.Systems.Os.PROCESS_INFORMATION;
      Command      : Wchar_Ptr := null;
      Pos          : Interfaces.C.size_t := 0;
      To_Close     : File_Type_Array_Access;
   end record;

   --  Wait for the process to exit.
   overriding
   procedure Wait (Sys     : in out System_Process;
                   Proc    : in out Process'Class;
                   Timeout : in Duration);

   --  Spawn a new process.
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE);

   --  Terminate the process by sending a signal on Unix and exiting the process on Windows.
   --  This operation is not portable and has a different behavior between Unix and Windows.
   --  Its intent is to stop the process.
   overriding
   procedure Stop (Sys    : in out System_Process;
                   Proc   : in out Process'Class;
                   Signal : in Positive := 15);

   --  Append the argument to the process argument list.
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String);

   --  Set the process input, output and error streams to redirect and use specified files.
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access);

   --  Deletes the storage held by the system process.
   overriding
   procedure Finalize (Sys : in out System_Process);

   --  Build the output pipe redirection to read the process output.
   procedure Build_Output_Pipe (Proc : in out Process'Class;
                                Into : in out Startup_Info);

   --  Build the input pipe redirection to write the process standard input.
   procedure Build_Input_Pipe (Proc : in out Process'Class;
                               Into : in out Startup_Info);

private

   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   function Create_Stream (File : in Util.Streams.Raw.File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access;

end Util.Processes.Os;

Add a To_Close parameter to Set_Streams

Add a To_Close parameter to Set_Streams


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

with Ada.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Enums;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;
with Gen.Model.Beans;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  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 : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "enums" then
         return From.Enums_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "beans" then
         return From.Beans_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given enum in the model.
   --  ------------------------------
   procedure Register_Enum (O      : in out Model_Definition;
                            Enum   : access Gen.Model.Enums.Enum_Definition'Class) is
      Name : constant String := Enum.Get_Name;
   begin
      Log.Info ("Registering enum {0}", Name);

      O.Register_Package (Enum.Pkg_Name, Enum.Package_Def);
      if Enum.Package_Def.Enums.Find (Name) /= null then
         raise Name_Exist with "Enum '" & Name & "' already defined";
      end if;
      Enum.Package_Def.Enums.Append (Enum.all'Access);
      O.Enums.Append (Enum.all'Access);
      Gen.Model.Mappings.Register_Type (To_String (Enum.Name), Enum.all'Access,
                                        Gen.Model.Mappings.T_ENUM);
   end Register_Enum;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
      Name : constant String := Table.Get_Name;
   begin
      Log.Info ("Registering table {0}", Name);

      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      if Table.Package_Def.Tables.Find (Name) /= null then
         raise Name_Exist with "Table '" & Name & "' already defined";
      end if;
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register the declaration of the given bean in the model.
   --  ------------------------------
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class) is
   begin
      O.Register_Package (Bean.Pkg_Name, Bean.Package_Def);
      Bean.Package_Def.Beans.Append (Bean.all'Access);
      O.Queries.Append (Bean.all'Access);
   end Register_Bean;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  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 (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 and Name /= O.Pkg_Name then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;

               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Definition_Access := Table_List.Element (Table_Iter);
            begin
               if Table.all in Table_Definition'Class then
                  Prepare_Table (Table_Definition_Access (Table));
               else
                  Table.Prepare;
               end if;
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      Log.Info ("Preparing package {0}", O.Pkg_Name);

      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      O.Enums.Sort;
      O.Queries.Sort;
      Prepare_Tables (O.Enums);
      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Enums_Bean   := Util.Beans.Objects.To_Object (O.Enums'Unchecked_Access, STATIC);
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Beans_Bean   := Util.Beans.Objects.To_Object (O.Beans'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  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 : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  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 : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  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 (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
      O.Tables.Sort;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

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

with Ada.Strings;
with Ada.Strings.Maps;

with Gen.Utils;
with Gen.Model.Enums;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Gen.Model.Mappings;
with Gen.Model.Beans;

with Util.Strings;
with Util.Strings.Transforms;
with Util.Log.Loggers;
package body Gen.Model.Packages is

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Model.Packages");

   --  ------------------------------
   --  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 : in Package_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Pkg_Name);

      elsif Name = "package" then
         return Util.Beans.Objects.To_Object (From.Base_Name);

      elsif Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "enums" then
         return From.Enums_Bean;

      elsif Name = "queries" then
         return From.Queries_Bean;

      elsif Name = "beans" then
         return From.Beans_Bean;

      elsif Name = "usedTypes" then
         return From.Used;

      elsif Name = "useCalendarTime" then
         return Util.Beans.Objects.To_Object (From.Uses_Calendar_Time);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Register the declaration of the given enum in the model.
   --  ------------------------------
   procedure Register_Enum (O      : in out Model_Definition;
                            Enum   : access Gen.Model.Enums.Enum_Definition'Class) is
      Name : constant String := Enum.Get_Name;
   begin
      Log.Info ("Registering enum {0}", Name);

      O.Register_Package (Enum.Pkg_Name, Enum.Package_Def);
      if Enum.Package_Def.Enums.Find (Name) /= null then
         raise Name_Exist with "Enum '" & Name & "' already defined";
      end if;
      Enum.Package_Def.Enums.Append (Enum.all'Access);
      O.Enums.Append (Enum.all'Access);
      Gen.Model.Mappings.Register_Type (To_String (Enum.Name), Enum.all'Access,
                                        Gen.Model.Mappings.T_ENUM);
   end Register_Enum;

   --  ------------------------------
   --  Register the declaration of the given table in the model.
   --  ------------------------------
   procedure Register_Table (O     : in out Model_Definition;
                             Table : access Gen.Model.Tables.Table_Definition'Class) is
      Name : constant String := Table.Get_Name;
   begin
      Log.Info ("Registering table {0}", Name);

      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      if Table.Package_Def.Tables.Find (Name) /= null then
         raise Name_Exist with "Table '" & Name & "' already defined";
      end if;
      Table.Package_Def.Tables.Append (Table.all'Access);
      O.Tables.Append (Table.all'Access);
   end Register_Table;

   --  ------------------------------
   --  Register the declaration of the given query in the model.
   --  ------------------------------
   procedure Register_Query (O     : in out Model_Definition;
                             Table : access Gen.Model.Queries.Query_Definition'Class) is
   begin
      O.Register_Package (Table.Pkg_Name, Table.Package_Def);
      Table.Package_Def.Queries.Append (Table.all'Access);
      O.Queries.Append (Table.all'Access);
   end Register_Query;

   --  ------------------------------
   --  Register the declaration of the given bean in the model.
   --  ------------------------------
   procedure Register_Bean (O     : in out Model_Definition;
                            Bean  : access Gen.Model.Beans.Bean_Definition'Class) is
   begin
      O.Register_Package (Bean.Pkg_Name, Bean.Package_Def);
      Bean.Package_Def.Beans.Append (Bean.all'Access);
      O.Queries.Append (Bean.all'Access);
   end Register_Bean;

   --  ------------------------------
   --  Register or find the package knowing its name
   --  ------------------------------
   procedure Register_Package (O      : in out Model_Definition;
                               Name   : in Unbounded_String;
                               Result : out Package_Definition_Access) is
      Pkg : constant String := Util.Strings.Transforms.To_Upper_Case (To_String (Name));
      Key : constant Unbounded_String := To_Unbounded_String (Pkg);
      Pos : constant Package_Map.Cursor := O.Packages.Find (Key);
   begin
      if not Package_Map.Has_Element (Pos) then
         declare
            Map : Ada.Strings.Maps.Character_Mapping;
            Base_Name : Unbounded_String;
         begin
            Map := Ada.Strings.Maps.To_Mapping (From => ".", To => "-");
            Base_Name := Translate (Name, Map);

            Result := new Package_Definition;
            Result.Pkg_Name := Name;
            Result.Tables_Bean := Util.Beans.Objects.To_Object (Result.Tables'Access,
                                                                Util.Beans.Objects.STATIC);
            Util.Strings.Transforms.To_Lower_Case (To_String (Base_Name),
                                                   Result.Base_Name);
            O.Packages.Insert (Key, Result);
            Log.Debug ("Ada package '{0}' registered", Name);
         end;
      else
         Result := Package_Map.Element (Pos);
      end if;
   end Register_Package;

   --  ------------------------------
   --  Returns True if the model contains at least one package.
   --  ------------------------------
   function Has_Packages (O : in Model_Definition) return Boolean is
   begin
      return not O.Packages.Is_Empty;
   end Has_Packages;

   --  ------------------------------
   --  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 (O : in out Package_Definition) is
      use Gen.Model.Tables;

      procedure Prepare_Table (Table : in Table_Definition_Access);
      procedure Prepare_Tables (Tables : in Table_List.List_Definition);

      Used_Types  : Gen.Utils.String_Set.Set;
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Used_Types'Unchecked_Access;

      procedure Prepare_Table (Table : in Table_Definition_Access) is
         C     : Column_List.Cursor := Table.Members.First;
      begin
         Table.Prepare;

         --  Walk the columns to get their type.
         while Column_List.Has_Element (C) loop
            declare
               Col  : constant Column_Definition_Access := Column_List.Element (C);
               T    : constant String := To_String (Col.Type_Name);
               Name : constant String := Gen.Utils.Get_Package_Name (T);
            begin
               if not Col.Is_Basic_Type and Name'Length > 0 and Name /= O.Pkg_Name then
                  Used_Types.Include (To_Unbounded_String (Name));

               elsif T = "Time" or T = "Date" or T = "Timestamp" or T = "Nullable_Time" then
                  O.Uses_Calendar_Time := True;

               end if;
            end;
            Column_List.Next (C);
         end loop;
      end Prepare_Table;

      procedure Prepare_Tables (Tables : in Table_List.List_Definition) is
         Table_Iter  : Table_List.Cursor := Tables.First;
      begin
         while Table_List.Has_Element (Table_Iter) loop
            declare
               Table : constant Definition_Access := Table_List.Element (Table_Iter);
            begin
               if Table.all in Table_Definition'Class then
                  Prepare_Table (Table_Definition_Access (Table));
               else
                  Table.Prepare;
               end if;
            end;
            Table_List.Next (Table_Iter);
         end loop;
      end Prepare_Tables;

   begin
      Log.Info ("Preparing package {0}", O.Pkg_Name);

      O.Used := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Used_Types.Row := 0;
      O.Used_Types.Values.Clear;
      O.Uses_Calendar_Time := False;

      O.Enums.Sort;
      O.Queries.Sort;
      Prepare_Tables (O.Enums);
      Prepare_Tables (O.Tables);
      Prepare_Tables (O.Queries);
      Prepare_Tables (O.Beans);
      declare
         P : Gen.Utils.String_Set.Cursor := Used_Types.First;
      begin
         while Gen.Utils.String_Set.Has_Element (P) loop
            declare
               Name : constant Unbounded_String := Gen.Utils.String_Set.Element (P);
            begin
               Log.Info ("with {0}", Name);
               O.Used_Types.Values.Append (Util.Beans.Objects.To_Object (Name));
            end;
            Gen.Utils.String_Set.Next (P);
         end loop;
      end;
   end Prepare;

   --  ------------------------------
   --  Initialize the package instance
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Package_Definition) is
      use Util.Beans.Objects;
   begin
      O.Enums_Bean   := Util.Beans.Objects.To_Object (O.Enums'Unchecked_Access, STATIC);
      O.Tables_Bean  := Util.Beans.Objects.To_Object (O.Tables'Unchecked_Access, STATIC);
      O.Queries_Bean := Util.Beans.Objects.To_Object (O.Queries'Unchecked_Access, STATIC);
      O.Beans_Bean   := Util.Beans.Objects.To_Object (O.Beans'Unchecked_Access, STATIC);
      O.Used         := Util.Beans.Objects.To_Object (O.Used_Types'Unchecked_Access, STATIC);
   end Initialize;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   overriding
   function Get_Count (From : List_Object) return Natural is
   begin
      Log.Debug ("Length {0}", Natural'Image (Natural (From.Values.Length)));
      return Natural (From.Values.Length);
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   overriding
   procedure Set_Row_Index (From  : in out List_Object;
                            Index : in Natural) is
   begin
      Log.Debug ("Setting row {0}", Natural'Image (Index));
      From.Row := Index;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   overriding
   function Get_Row (From  : List_Object) return Util.Beans.Objects.Object is
   begin
      Log.Debug ("Getting row {0}", Natural'Image (From.Row));
      return From.Values.Element (From.Row - 1);
   end Get_Row;

   --  ------------------------------
   --  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 : in List_Object;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);
      pragma Unreferenced (Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  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 : in Model_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tables" then
         return From.Tables_Bean;

      elsif Name = "dirname" then
         return Util.Beans.Objects.To_Object (From.Dir_Name);

      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the directory name associated with the model. This directory name allows to
   --  save and build a model in separate directories for the application, the unit tests
   --  and others.
   --  ------------------------------
   procedure Set_Dirname (O : in out Model_Definition;
                          Target_Dir : in String;
                          Model_Dir  : in String) is
   begin
      O.Dir_Name := To_Unbounded_String (Target_Dir);
      O.DB_Name  := To_Unbounded_String (Model_Dir);
   end Set_Dirname;

   --  ------------------------------
   --  Get the directory name associated with the model.
   --  ------------------------------
   function Get_Dirname (O : in Model_Definition) return String is
   begin
      return To_String (O.Dir_Name);
   end Get_Dirname;

   --  ------------------------------
   --  Get the directory name which contains the model.
   --  ------------------------------
   function Get_Model_Directory (O : in Model_Definition) return String is
   begin
      return To_String (O.DB_Name);
   end Get_Model_Directory;

   --  ------------------------------
   --  Initialize the model definition instance.
   --  ------------------------------
   overriding
   procedure Initialize (O : in out Model_Definition) is
      T : constant Util.Beans.Basic.Readonly_Bean_Access := O.Tables'Unchecked_Access;
   begin
      O.Tables_Bean := Util.Beans.Objects.To_Object (T, Util.Beans.Objects.STATIC);
      O.Dir_Name    := To_Unbounded_String ("src");
   end Initialize;

   --  ------------------------------
   --  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 (O : in out Model_Definition) is
      Iter : Package_Cursor := O.Packages.First;
   begin
      while Has_Element (Iter) loop
         Element (Iter).Prepare;
         Next (Iter);
      end loop;
      O.Tables.Sort;
   end Prepare;

   --  ------------------------------
   --  Get the first package of the model definition.
   --  ------------------------------
   function First (From : Model_Definition) return Package_Cursor is
   begin
      return From.Packages.First;
   end First;

   --  ------------------------------
   --  Register a type mapping.  The From type describes a type in the XML
   --  configuration files (hibernate, query, ...) and the To represents the
   --  corresponding Ada type.
   --  ------------------------------
   procedure Register_Type (O    : in out Model_Definition;
                            From : in String;
                            To   : in String) is
   begin
      null;
   end Register_Type;

end Gen.Model.Packages;

Prepare the Ada beans by invoking the Prepare operation on each of them


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

with Security.Contexts;
with Security.Permissions;

with Util.Beans.Objects;
with Util.Serialize.IO.XML;

package Security.Controllers.Roles is

   --  ------------------------------
   --  Security Controller
   --  ------------------------------
   --  The Role_Controller implements a simple role based permissions check.
   --  The permission is granted if the user has the role defined by the controller.
   type Role_Controller (Count : Positive) is limited new Controller with record
      Roles : Permissions.Role_Type_Array (1 .. Count);
   end record;
   type Role_Controller_Access is access all Role_Controller'Class;

   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Security.Permissions.Permission_Manager_Access;
   end record;

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Controller_Config;
   end Reader_Config;

end Security.Controllers.Roles;

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

with Security.Contexts;
with Security.Permissions;

with Util.Beans.Objects;
with Util.Serialize.IO.XML;
with Security.Policies.Roles;

package Security.Controllers.Roles is

   --  ------------------------------
   --  Security Controller
   --  ------------------------------
   --  The Role_Controller implements a simple role based permissions check.
   --  The permission is granted if the user has the role defined by the controller.
   type Role_Controller (Count : Positive) is limited new Controller with record
      Roles : Policies.Roles.Role_Type_Array (1 .. Count);
   end record;
   type Role_Controller_Access is access all Role_Controller'Class;

   --  Returns true if the user associated with the security context Context has
   --  one of the role defined in the Handler.
   function Has_Permission (Handler    : in Role_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Permissions.Role_Type_Array (1 .. Integer (Permissions.Role_Type'Last));
      Count   : Natural := 0;
      Manager : Security.Permissions.Permission_Manager_Access;
   end record;

   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Controller_Config;
   end Reader_Config;

end Security.Controllers.Roles;

Use the Security.Policies.Roles package

Use the Security.Policies.Roles package


-----------------------------------------------------------------------
--  wiki-render-text -- Wiki Text renderer
--  Copyright (C) 2011, 2012, 2013, 2015, 2016, 2018, 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.
-----------------------------------------------------------------------
with Wiki.Helpers;
package body Wiki.Render.Text is

   --  ------------------------------
   --  Set the output writer.
   --  ------------------------------
   procedure Set_Output_Stream (Engine : in out Text_Renderer;
                                Stream : in Streams.Output_Stream_Access) is
   begin
      Engine.Output := Stream;
   end Set_Output_Stream;

   --  ------------------------------
   --  Set the no-newline mode to produce a single line text (disabled by default).
   --  ------------------------------
   procedure Set_No_Newline (Engine : in out Text_Renderer;
                             Enable : in Boolean) is
   begin
      Engine.No_Newline := Enable;
   end Set_No_Newline;

   --  ------------------------------
   --  Emit a new line.
   --  ------------------------------
   procedure New_Line (Document : in out Text_Renderer) is
   begin
      if not Document.No_Newline then
         Document.Output.Write (Wiki.Helpers.LF);
      end if;
      Document.Empty_Line := True;
   end New_Line;

   --  ------------------------------
   --  Add a line break (<br>).
   --  ------------------------------
   procedure Add_Line_Break (Document : in out Text_Renderer) is
   begin
      if not Document.No_Newline then
         Document.Output.Write (Wiki.Helpers.LF);
      end if;
      Document.Empty_Line := True;
   end Add_Line_Break;

   --  ------------------------------
   --  Render a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   procedure Render_Blockquote (Engine : in out Text_Renderer;
                                Level  : in Natural) is
   begin
      Engine.Close_Paragraph;
      for I in 1 .. Level loop
         Engine.Output.Write ("  ");
      end loop;
   end Render_Blockquote;

   --  ------------------------------
   --  Render a list item (<li>).  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.
   --  ------------------------------
   procedure Render_List_Item (Engine   : in out Text_Renderer;
                               Level    : in Positive;
                               Ordered  : in Boolean) is
      pragma Unreferenced (Level, Ordered);
   begin
      if not Engine.Empty_Line then
         Engine.Add_Line_Break;
      end if;
      Engine.Need_Paragraph := False;
      Engine.Open_Paragraph;
   end Render_List_Item;

   procedure Close_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Has_Paragraph then
         Document.Add_Line_Break;
      end if;
      Document.Has_Paragraph := False;
   end Close_Paragraph;

   procedure Open_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Need_Paragraph then
         Document.Has_Paragraph  := True;
         Document.Need_Paragraph := False;
      end if;
   end Open_Paragraph;

   --  ------------------------------
   --  Render a link.
   --  ------------------------------
   procedure Render_Link (Engine : in out Text_Renderer;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List) is
      Href : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attr, "href");
   begin
      Engine.Open_Paragraph;
      if Title'Length /= 0 then
         Engine.Output.Write (Title);
      end if;
      if Title /= Href and Href'Length /= 0 then
         if Title'Length /= 0 then
            Engine.Output.Write (" (");
         end if;
         Engine.Output.Write (Href);
         if Title'Length /= 0 then
            Engine.Output.Write (")");
         end if;
      end if;
      Engine.Empty_Line := False;
   end Render_Link;

   --  ------------------------------
   --  Render an image.
   --  ------------------------------
   procedure Render_Image (Engine   : in out Text_Renderer;
                           Title    : in Wiki.Strings.WString;
                           Attr     : in Wiki.Attributes.Attribute_List) is
      Desc : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attr, "longdesc");
   begin
      Engine.Open_Paragraph;
      if Title'Length > 0 then
         Engine.Output.Write (Title);
      end if;
      if Title'Length > 0 and Desc'Length > 0 then
         Engine.Output.Write (' ');
      end if;
      if Desc'Length > 0 then
         Engine.Output.Write (Desc);
      end if;
      Engine.Empty_Line := False;
   end Render_Image;

   --  ------------------------------
   --  Render a text block that is pre-formatted.
   --  ------------------------------
   procedure Render_Preformatted (Engine : in out Text_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Wiki.Strings.WString) is
      pragma Unreferenced (Format);
   begin
      Engine.Close_Paragraph;
      Engine.Output.Write (Text);
      Engine.Empty_Line := False;
   end Render_Preformatted;

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Text_Renderer;
                     Doc    : in Wiki.Documents.Document;
                     Node   : in Wiki.Nodes.Node_Type) is
      use type Wiki.Nodes.Node_List_Access;
   begin
      case Node.Kind is
         when Wiki.Nodes.N_HEADER =>
            Engine.Close_Paragraph;
            if not Engine.Empty_Line then
               Engine.Add_Line_Break;
            end if;
            Engine.Output.Write (Node.Header);
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_LINE_BREAK =>
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_HORIZONTAL_RULE =>
            Engine.Close_Paragraph;
            Engine.Output.Write ("---------------------------------------------------------");
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_PARAGRAPH =>
            Engine.Close_Paragraph;
            Engine.Need_Paragraph := True;
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_NEWLINE =>
            if not Engine.No_Newline then
               Engine.Output.Write (Wiki.Helpers.LF);
            else
               Engine.Output.Write (' ');
            end if;

         when Wiki.Nodes.N_INDENT =>
            Engine.Indent_Level := Node.Level;

         when Wiki.Nodes.N_BLOCKQUOTE =>
            Engine.Render_Blockquote (Node.Level);

         when Wiki.Nodes.N_LIST =>
            Engine.Render_List_Item (Node.Level, False);

         when Wiki.Nodes.N_NUM_LIST =>
            Engine.Render_List_Item (Node.Level, True);

         when Wiki.Nodes.N_TEXT =>
            if Engine.Empty_Line and Engine.Indent_Level /= 0 then
               for I in 1 .. Engine.Indent_Level loop
                  Engine.Output.Write (' ');
               end loop;
            end if;
            Engine.Output.Write (Node.Text);
            Engine.Empty_Line := False;

         when Wiki.Nodes.N_QUOTE =>
            Engine.Open_Paragraph;
            Engine.Output.Write (Node.Title);
            Engine.Empty_Line := False;

         when Wiki.Nodes.N_LINK =>
            Engine.Render_Link (Node.Title, Node.Link_Attr);

         when Wiki.Nodes.N_IMAGE =>
            Engine.Render_Image (Node.Title, Node.Link_Attr);

         when Wiki.Nodes.N_PREFORMAT =>
            Engine.Render_Preformatted (Node.Preformatted, "");

         when Wiki.Nodes.N_TAG_START =>
            if Node.Children /= null then
               if Node.Tag_Start = Wiki.DT_TAG then
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
                  Engine.Render (Doc, Node.Children);
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
               elsif Node.Tag_Start = Wiki.DD_TAG then
                  Engine.Close_Paragraph;
                  Engine.Empty_Line := True;
                  Engine.Indent_Level := 4;
                  Engine.Render (Doc, Node.Children);
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
               else
                  Engine.Render (Doc, Node.Children);
                  if Node.Tag_Start = Wiki.DL_TAG then
                     Engine.Close_Paragraph;
                     Engine.New_Line;
                  end if;
               end if;
            end if;

         when others =>
            null;

      end case;
   end Render;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Engine : in out Text_Renderer;
                     Doc    : in Wiki.Documents.Document) is
      pragma Unreferenced (Doc);
   begin
      Engine.Close_Paragraph;
   end Finish;

end Wiki.Render.Text;

-----------------------------------------------------------------------
--  wiki-render-text -- Wiki Text renderer
--  Copyright (C) 2011, 2012, 2013, 2015, 2016, 2018, 2019, 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 Wiki.Helpers;
with Util.Strings;
package body Wiki.Render.Text is

   --  ------------------------------
   --  Set the output writer.
   --  ------------------------------
   procedure Set_Output_Stream (Engine : in out Text_Renderer;
                                Stream : in Streams.Output_Stream_Access) is
   begin
      Engine.Output := Stream;
   end Set_Output_Stream;

   --  ------------------------------
   --  Set the no-newline mode to produce a single line text (disabled by default).
   --  ------------------------------
   procedure Set_No_Newline (Engine : in out Text_Renderer;
                             Enable : in Boolean) is
   begin
      Engine.No_Newline := Enable;
   end Set_No_Newline;

   --  ------------------------------
   --  Emit a new line.
   --  ------------------------------
   procedure New_Line (Document : in out Text_Renderer) is
   begin
      if not Document.No_Newline then
         Document.Output.Write (Wiki.Helpers.LF);
      end if;
      Document.Empty_Line := True;
   end New_Line;

   --  ------------------------------
   --  Add a line break (<br>).
   --  ------------------------------
   procedure Add_Line_Break (Document : in out Text_Renderer) is
   begin
      if not Document.No_Newline then
         Document.Output.Write (Wiki.Helpers.LF);
      end if;
      Document.Empty_Line := True;
      Document.Current_Indent := 0;
   end Add_Line_Break;

   --  ------------------------------
   --  Render a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   procedure Render_Blockquote (Engine : in out Text_Renderer;
                                Level  : in Natural) is
   begin
      Engine.Close_Paragraph;
      for I in 1 .. Level loop
         Engine.Output.Write ("  ");
      end loop;
   end Render_Blockquote;

   procedure Render_List_Start (Engine   : in out Text_Renderer;
                                Tag      : in String;
                                Level    : in Natural) is
   begin
      if not Engine.Empty_Line then
         Engine.Add_Line_Break;
      end if;
      Engine.Need_Paragraph := False;
      Engine.Open_Paragraph;
      if not Engine.No_Newline then
         Engine.Output.Write (Wiki.Helpers.LF);
      end if;
      Engine.List_Index := Engine.List_Index + 1;
      Engine.List_Levels (Engine.List_Index) := Level;
      Engine.Indent_Level := Engine.Indent_Level + 2;
   end Render_List_Start;

   procedure Render_List_End (Engine   : in out Text_Renderer;
                              Tag      : in String) is
   begin
      if not Engine.Empty_Line then
         Engine.Add_Line_Break;
      end if;
      Engine.Need_Paragraph := False;
      Engine.Open_Paragraph;
      Engine.List_Index := Engine.List_Index - 1;
      Engine.Indent_Level := Engine.Indent_Level - 2;
   end Render_List_End;

   --  ------------------------------
   --  Render a list item (<li>).  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.
   --  ------------------------------
   procedure Render_List_Item_Start (Engine   : in out Text_Renderer) is
   begin
      if not Engine.Empty_Line then
         Engine.Add_Line_Break;
      end if;
      Engine.Need_Paragraph := False;
      Engine.Open_Paragraph;

      if Engine.List_Levels (Engine.List_Index) > 0 then
         Engine.Render_Paragraph (Strings.To_Wstring (Util.Strings.Image (Engine.List_Levels (Engine.List_Index))));
         Engine.List_Levels (Engine.List_Index) := Engine.List_Levels (Engine.List_index) + 1;
         Engine.Render_Paragraph (") ");
         Engine.Indent_Level := Engine.Indent_Level + 4;
      else
         Engine.Render_Paragraph ("- ");
         Engine.Indent_Level := Engine.Indent_Level + 2;
      end if;
   end Render_List_Item_Start;

   procedure Render_List_Item_End (Engine   : in out Text_Renderer) is
   begin
      if not Engine.Empty_Line then
         Engine.Add_Line_Break;
      end if;
      Engine.Need_Paragraph := False;
      Engine.Open_Paragraph;
      if Engine.List_Levels (Engine.List_Index) > 0 then
         Engine.Indent_Level := Engine.Indent_Level - 4;
      else
         Engine.Indent_Level := Engine.Indent_Level - 2;
      end if;
   end Render_List_Item_End;

   procedure Close_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Has_Paragraph then
         Document.Add_Line_Break;
      end if;
      Document.Has_Paragraph := False;
   end Close_Paragraph;

   procedure Open_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Need_Paragraph then
         Document.Has_Paragraph  := True;
         Document.Need_Paragraph := False;
      end if;
   end Open_Paragraph;

   --  ------------------------------
   --  Render a link.
   --  ------------------------------
   procedure Render_Link (Engine : in out Text_Renderer;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List) is
      Href : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attr, "href");
   begin
      Engine.Open_Paragraph;
      if Title'Length /= 0 then
         Engine.Output.Write (Title);
      end if;
      if Title /= Href and Href'Length /= 0 then
         if Title'Length /= 0 then
            Engine.Output.Write (" (");
         end if;
         Engine.Output.Write (Href);
         if Title'Length /= 0 then
            Engine.Output.Write (")");
         end if;
      end if;
      Engine.Empty_Line := False;
   end Render_Link;

   --  ------------------------------
   --  Render an image.
   --  ------------------------------
   procedure Render_Image (Engine   : in out Text_Renderer;
                           Title    : in Wiki.Strings.WString;
                           Attr     : in Wiki.Attributes.Attribute_List) is
      Desc : constant Wiki.Strings.WString := Wiki.Attributes.Get_Attribute (Attr, "longdesc");
   begin
      Engine.Open_Paragraph;
      if Title'Length > 0 then
         Engine.Output.Write (Title);
      end if;
      if Title'Length > 0 and Desc'Length > 0 then
         Engine.Output.Write (' ');
      end if;
      if Desc'Length > 0 then
         Engine.Output.Write (Desc);
      end if;
      Engine.Empty_Line := False;
   end Render_Image;

   --  ------------------------------
   --  Render a text block that is pre-formatted.
   --  ------------------------------
   procedure Render_Preformatted (Engine : in out Text_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Wiki.Strings.WString) is
      pragma Unreferenced (Format);
   begin
      Engine.Close_Paragraph;
      Engine.Output.Write (Text);
      Engine.Empty_Line := False;
   end Render_Preformatted;

   --  ------------------------------
   --  Render a text block indenting the text if necessary.
   --  ------------------------------
   procedure Render_Paragraph (Engine : in out Text_Renderer;
                               Text   : in Wiki.Strings.WString) is
   begin
      for C of Text loop
         if C = Helpers.LF then
            Engine.Empty_Line := True;
            Engine.Current_Indent := 0;
            Engine.Output.Write (C);
         else
            while Engine.Current_Indent < Engine.Indent_Level loop
               Engine.Output.Write (' ');
               Engine.Current_Indent := Engine.Current_Indent + 1;
            end loop;

            Engine.Output.Write (C);
            Engine.Empty_Line := False;
            Engine.Current_Indent := Engine.Current_Indent + 1;
            Engine.Has_Paragraph := True;
         end if;
      end loop;
   end Render_Paragraph;

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Text_Renderer;
                     Doc    : in Wiki.Documents.Document;
                     Node   : in Wiki.Nodes.Node_Type) is
      use type Wiki.Nodes.Node_List_Access;
   begin
      case Node.Kind is
         when Wiki.Nodes.N_HEADER =>
            Engine.Close_Paragraph;
            if not Engine.Empty_Line then
               Engine.Add_Line_Break;
            end if;
            Engine.Output.Write (Node.Header);
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_LINE_BREAK =>
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_HORIZONTAL_RULE =>
            Engine.Close_Paragraph;
            Engine.Output.Write ("---------------------------------------------------------");
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_PARAGRAPH =>
            Engine.Close_Paragraph;
            Engine.Need_Paragraph := True;
            Engine.Add_Line_Break;

         when Wiki.Nodes.N_NEWLINE =>
            if not Engine.No_Newline then
               Engine.Output.Write (Wiki.Helpers.LF);
            else
               Engine.Output.Write (' ');
            end if;

         when Wiki.Nodes.N_INDENT =>
            Engine.Indent_Level := Node.Level;

         when Wiki.Nodes.N_BLOCKQUOTE =>
            Engine.Render_Blockquote (Node.Level);

         when Wiki.Nodes.N_LIST_START =>
            Engine.Render_List_Start ("o", 0);

         when Wiki.Nodes.N_NUM_LIST_START =>
            Engine.Render_List_Start (".", Node.Level);

         when Wiki.Nodes.N_LIST_END =>
            Engine.Render_List_End ("");

         when Wiki.Nodes.N_NUM_LIST_END =>
            Engine.Render_List_End ("");

         when Wiki.Nodes.N_LIST_ITEM =>
            Engine.Render_List_Item_Start;

         when Wiki.Nodes.N_LIST_ITEM_END =>
            Engine.Render_List_Item_End;

         when Wiki.Nodes.N_TEXT =>
            Engine.Render_Paragraph (Node.Text);

         when Wiki.Nodes.N_QUOTE =>
            Engine.Open_Paragraph;
            Engine.Output.Write (Node.Title);
            Engine.Empty_Line := False;

         when Wiki.Nodes.N_LINK =>
            Engine.Render_Link (Node.Title, Node.Link_Attr);

         when Wiki.Nodes.N_IMAGE =>
            Engine.Render_Image (Node.Title, Node.Link_Attr);

         when Wiki.Nodes.N_PREFORMAT =>
            Engine.Render_Preformatted (Node.Preformatted, "");

         when Wiki.Nodes.N_TAG_START =>
            if Node.Children /= null then
               if Node.Tag_Start = Wiki.DT_TAG then
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
                  Engine.Render (Doc, Node.Children);
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
               elsif Node.Tag_Start = Wiki.DD_TAG then
                  Engine.Close_Paragraph;
                  Engine.Empty_Line := True;
                  Engine.Indent_Level := 4;
                  Engine.Render (Doc, Node.Children);
                  Engine.Close_Paragraph;
                  Engine.Indent_Level := 0;
               else
                  Engine.Render (Doc, Node.Children);
                  if Node.Tag_Start = Wiki.DL_TAG then
                     Engine.Close_Paragraph;
                     Engine.New_Line;
                  end if;
               end if;
            end if;

         when others =>
            null;

      end case;
   end Render;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Engine : in out Text_Renderer;
                     Doc    : in Wiki.Documents.Document) is
      pragma Unreferenced (Doc);
   begin
      Engine.Close_Paragraph;
   end Finish;

end Wiki.Render.Text;

Add support to render lists and provide a better presentation