-----------------------------------------------------------------------
--  security-filters -- Security filter
--  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 Ada.Strings.Unbounded;

with Util.Log.Loggers;

with ASF.Cookies;
with ASF.Applications.Main;

with Security.Contexts;
with Security.Policies.Urls;
package body ASF.Security.Filters is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Filters");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
      use ASF.Applications.Main;
   begin
      if Context in Application'Class then
         Server.Set_Permission_Manager (Application'Class (Context).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
      use Policies.Urls;
      use type Policies.Policy_Manager_Access;

      Session : ASF.Sessions.Session;
      SID     : Unbounded_String;
      AID     : Unbounded_String;
      Auth    : ASF.Principals.Principal_Access;

      pragma Unreferenced (SID);

      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie);

      --  ------------------------------
      --  Collect the AID and SID cookies.
      --  ------------------------------
      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie) is
         Name : constant String := ASF.Cookies.Get_Name (Cookie);
      begin
         if Name = SID_COOKIE then
            SID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         elsif Name = AID_COOKIE then
            AID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         end if;
      end Fetch_Cookie;

      Context : aliased Contexts.Security_Context;
   begin
      Request.Iterate_Cookies (Fetch_Cookie'Access);

      Session := Request.Get_Session (Create => True);

      --  If the session does not have a principal, try to authenticate the user with
      --  the auto-login cookie.
      Auth := Session.Get_Principal;
      if Auth = null then
         Auth_Filter'Class (F).Authenticate (Request, Response, Session, To_String (AID), Auth);
         if Auth /= null then
            Session.Set_Principal (Auth);
         end if;
      end if;

      --  No principal, redirect to the login page.
      if Auth = null then
         Auth_Filter'Class (F).Do_Login (Request, Response);
         return;
      end if;

      --  A permission manager is installed, check that the user can display the page.
      if F.Manager /= null then
         Context.Set_Context (F.Manager, Auth.all'Access);
         declare
            URI  : constant String := Request.Get_Path_Info;
            Perm : constant Policies.URLs.URI_Permission (URI'Length)
              := URI_Permission '(Len => URI'Length, URI => URI);
         begin
            if not F.Manager.Has_Permission (Context, Perm) then
               Log.Info ("Deny access on {0}", URI);
--                 Auth_Filter'Class (F).Do_Deny (Request, Response);
--                 return;
            end if;
         end;
      end if;

      --  Request is authorized, proceed to the next filter.
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
   begin
      null;
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

   --  ------------------------------
   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   --  ------------------------------
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (F, Request, Response, Session, Auth_Id);
   begin
      Principal := null;
   end Authenticate;

end ASF.Security.Filters;

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

with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with ASF.Cookies;
with ASF.Applications.Main;

with Security.Contexts;
with Security.Policies.URLs;
package body ASF.Security.Filters is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Filters");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class) is
      use ASF.Applications.Main;
   begin
      if Context in Application'Class then
         Server.Set_Permission_Manager (Application'Class (Context).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
      use Policies.URLs;
      use type Policies.Policy_Manager_Access;

      Session : ASF.Sessions.Session;
      SID     : Unbounded_String;
      AID     : Unbounded_String;
      Auth    : ASF.Principals.Principal_Access;

      pragma Unreferenced (SID);

      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie);

      --  ------------------------------
      --  Collect the AID and SID cookies.
      --  ------------------------------
      procedure Fetch_Cookie (Cookie : in ASF.Cookies.Cookie) is
         Name : constant String := ASF.Cookies.Get_Name (Cookie);
      begin
         if Name = SID_COOKIE then
            SID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         elsif Name = AID_COOKIE then
            AID := To_Unbounded_String (ASF.Cookies.Get_Value (Cookie));
         end if;
      end Fetch_Cookie;

      Context : aliased Contexts.Security_Context;
   begin
      Request.Iterate_Cookies (Fetch_Cookie'Access);

      Session := Request.Get_Session (Create => True);

      --  If the session does not have a principal, try to authenticate the user with
      --  the auto-login cookie.
      Auth := Session.Get_Principal;
      if Auth = null then
         Auth_Filter'Class (F).Authenticate (Request, Response, Session, To_String (AID), Auth);
         if Auth /= null then
            Session.Set_Principal (Auth);
         end if;
      end if;

      --  No principal, redirect to the login page.
      if Auth = null then
         Auth_Filter'Class (F).Do_Login (Request, Response);
         return;
      end if;

      --  A permission manager is installed, check that the user can display the page.
      if F.Manager /= null then
         Context.Set_Context (F.Manager, Auth.all'Access);
         declare
            URL  : constant String := Request.Get_Path_Info;
            Perm : constant Policies.URLs.URL_Permission (URL'Length)
              := URL_Permission '(Len => URL'Length, URL => URL);
         begin
            if not F.Manager.Has_Permission (Context, Perm) then
               Log.Info ("Deny access on {0}", URL);
--                 Auth_Filter'Class (F).Do_Deny (Request, Response);
--                 return;
            end if;
         end;
      end if;

      --  Request is authorized, proceed to the next filter.
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
   begin
      null;
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

   --  ------------------------------
   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   --  ------------------------------
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access) is
      pragma Unreferenced (F, Request, Response, Session, Auth_Id);
   begin
      Principal := null;
   end Authenticate;

end ASF.Security.Filters;

Update after changes in Security package


-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;

   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l:") is
         when ASCII.NUL => exit;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
   end Help;

end Gen.Commands.Project;

-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  Execute the command with the arguments.
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: -web -tool -ado") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] [-web] [-tool] [-ado] "
                & "NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
      New_Line;
      Put_Line ("  -web   Generate a Web application");
      Put_Line ("  -tool  Generate a command line tool");
      Put_Line ("  -ado   Generate a database tool operation for ADO");
   end Help;

end Gen.Commands.Project;

Add new options to create-project command to generate command line applications, database applications or web applications


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

with Util.Tests;

package Util.Streams.Buffered.Lzma.Tests is

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

   type Test is new Util.Tests.Test with null record;

   procedure Test_Compress_Stream (T : in out Test);

   procedure Test_Compress_File_Stream (T : in out Test);

end Util.Streams.Buffered.Lzma.Tests;

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

with Util.Tests;

package Util.Streams.Buffered.Lzma.Tests is

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

   type Test is new Util.Tests.Test with null record;

   procedure Test_Compress_Stream (T : in out Test);

   procedure Test_Compress_File_Stream (T : in out Test);

   procedure Test_Compress_Decompress_Stream (T : in out Test);

end Util.Streams.Buffered.Lzma.Tests;

Declare the Test_Compress_Decompress_Stream procedure


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      --  Get the permission name associated with the index.
      function Get_Name (Index : in Permission_Index) return String;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := NONE + 1;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  ------------------------------
      --  Get the last permission index registered in the global permission map.
      --  ------------------------------
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index - 1;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            if Next_Index = Permission_Index'Last then
               Log.Error ("Too many permission instantiated. "
                          & "Increase Security.Permissions.MAX_PERMISSION");
            else
               Next_Index := Next_Index + 1;
            end if;
         end if;
      end Add_Permission;

      --  ------------------------------
      --  Get the permission name associated with the index.
      --  ------------------------------
      function Get_Name (Index : in Permission_Index) return String is
         Iter : Permission_Maps.Cursor := Map.First;
      begin
         while Permission_Maps.Has_Element (Iter) loop
            if Permission_Maps.Element (Iter) = Index then
               return Permission_Maps.Key (Iter);
            end if;
            Permission_Maps.Next (Iter);
         end loop;
         return "";
      end Get_Name;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the permission name given the index.
   --  ------------------------------
   function Get_Name (Index : in Permission_Index) return String is
   begin
      return Permission_Indexes.Get_Name (Index);
   end Get_Name;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   --  ------------------------------
   --  Check if the permission index set contains the given permission index.
   --  ------------------------------
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean is
      use Interfaces;
   begin
      return (Set (Natural (Index / 8)) and Shift_Left (1, Natural (Index mod 8))) /= 0;
   end Has_Permission;

   --  ------------------------------
   --  Add the permission index to the set.
   --  ------------------------------
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index) is
      use Interfaces;
      Pos : constant Natural := Natural (Index / 8);
   begin
      Set (Pos) := Set (Pos) or Shift_Left (1, Natural (Index mod 8));
   end Add_Permission;

   package body Definition is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Definition;

end Security.Permissions;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Strings.Tokenizers;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      --  Get the permission name associated with the index.
      function Get_Name (Index : in Permission_Index) return String;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := NONE + 1;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  ------------------------------
      --  Get the last permission index registered in the global permission map.
      --  ------------------------------
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index - 1;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            if Next_Index = Permission_Index'Last then
               Log.Error ("Too many permission instantiated. "
                          & "Increase Security.Permissions.MAX_PERMISSION");
            else
               Next_Index := Next_Index + 1;
            end if;
         end if;
      end Add_Permission;

      --  ------------------------------
      --  Get the permission name associated with the index.
      --  ------------------------------
      function Get_Name (Index : in Permission_Index) return String is
         Iter : Permission_Maps.Cursor := Map.First;
      begin
         while Permission_Maps.Has_Element (Iter) loop
            if Permission_Maps.Element (Iter) = Index then
               return Permission_Maps.Key (Iter);
            end if;
            Permission_Maps.Next (Iter);
         end loop;
         return "";
      end Get_Name;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   function Occurence (List : in String; Of_Char : in Character) return Natural is
      Count : Natural := 0;
   begin
      if List'Length > 0 then
         Count := 1;
         for C of List loop
            if C = Of_Char then
               Count := Count + 1;
            end if;
         end loop;
      end if;
      return Count;
   end Occurence;

   --  ------------------------------
   --  Get the list of permissions whose name is given in the string with separated comma.
   --  ------------------------------
   function Get_Permission_Array (List : in String) return Permission_Index_Array is
      Result : Permission_Index_Array (1 .. Occurence (List, ','));
      Count  : Natural := 0;

      procedure Process (Name : in String;
                         Done : out Boolean) is
      begin
         Done := False;
         Result (Count + 1) := Get_Permission_Index (Name);
         Count := Count + 1;

      exception
         when Invalid_Name =>
            Log.Info ("Permission {0} does not exist", Name);

      end Process;
   begin
      Util.Strings.Tokenizers.Iterate_Tokens (Content => List,
                                              Pattern => ",",
                                              Process => Process'Access,
                                              Going   => Ada.Strings.Forward);
      return Result (1 .. Count);
   end Get_Permission_Array;

   --  ------------------------------
   --  Get the permission name given the index.
   --  ------------------------------
   function Get_Name (Index : in Permission_Index) return String is
   begin
      return Permission_Indexes.Get_Name (Index);
   end Get_Name;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   --  ------------------------------
   --  Check if the permission index set contains the given permission index.
   --  ------------------------------
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean is
      use Interfaces;
   begin
      return (Set (Natural (Index / 8)) and Shift_Left (1, Natural (Index mod 8))) /= 0;
   end Has_Permission;

   --  ------------------------------
   --  Add the permission index to the set.
   --  ------------------------------
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index) is
      use Interfaces;
      Pos : constant Natural := Natural (Index / 8);
   begin
      Set (Pos) := Set (Pos) or Shift_Left (1, Natural (Index mod 8));
   end Add_Permission;

   package body Definition is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Definition;

end Security.Permissions;

Implement the Get_Permission_Array function to split the string into tokens and lookup the permission and return them as an array


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

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

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

--  == Permission ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.  An application should declare each permission
--  by instantiating the <tt>Definition</tt> package:
--
--    package Perm_Create_Workspace is new Security.Permissions.Definition ("create-workspace");
--
--  This declares a permission that can be represented by "<tt>create-workspace</tt>" in
--  configuration files.  In Ada, the permission is used as follows:
--
--     Perm_Create_Workspace.Permission
--
package Security.Permissions is

   Invalid_Name   : exception;

   --  Max number of permissions supported by the implementation.
   MAX_PERMISSION : constant Natural := 255;

   type Permission_Index is new Natural range 0 .. MAX_PERMISSION;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   NONE : constant Permission_Index := Permission_Index'First;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  The permission root class.
   --  Each permission is represented by a Permission_Index number to provide a fast
   --  and efficient permission check.
   type Permission (Id : Permission_Index) is tagged limited null record;

   generic
      Name : String;
   package Definition is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Definition;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   type Permission_Index_Set is private;

   --  Check if the permission index set contains the given permission index.
   function Has_Permission (Set   : in Permission_Index_Set;
                            Index : in Permission_Index) return Boolean;

   --  Add the permission index to the set.
   procedure Add_Permission (Set   : in out Permission_Index_Set;
                             Index : in Permission_Index);

   --  The empty set of permission indexes.
   EMPTY_SET : constant Permission_Index_Set;

private

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   INDEX_SET_SIZE : constant Natural := (MAX_PERMISSION + 7) / 8;

   type Permission_Index_Set is array (0 .. INDEX_SET_SIZE - 1) of Interfaces.Unsigned_8;

   EMPTY_SET : constant Permission_Index_Set := (others => 0);

end Security.Permissions;

Declare the Permission_Index_Array type

Declare the Permission_Index_Array type


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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Reader is limited interface;

   --  Start a document.
   procedure Start_Document (Stream : in out Reader) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Reader) is null;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is abstract;

   type Parser is abstract new Util.Log.Logging with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

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

with Ada.Strings.Unbounded;
with Ada.Calendar;

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Log.Loggers;
with Util.Nullables;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Nullables.Nullable_String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Nullables.Nullable_String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Ada.Calendar.Time) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Enum_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Reader is limited interface;

   --  Start a document.
   procedure Start_Document (Stream : in out Reader) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Reader) is null;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Reader;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Reader;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Start_Array (Handler : in out Reader;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is abstract;

   procedure Finish_Array (Handler : in out Reader;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is abstract;

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Reader;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Logger    : in out Util.Log.Logging'Class;
                         Attribute : in Boolean := False) is abstract;

   type Parser is abstract new Util.Log.Logging with private;

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class;
                    Sink    : in out Reader'Class) is abstract;

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String;
                    Sink    : in out Reader'Class);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String;
                           Sink    : in out Reader'Class);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

private

   type Parser is abstract new Util.Log.Logging with record
      Error_Flag     : Boolean := False;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

Declare Write_Attribute and Write_Entity for Nullable_String


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

with Ada.Text_IO;
with ASF.Applications.Main;
with ASF.Applications.Views;
with ASF.Components.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with EL.Contexts;
with EL.Contexts.Default;
with EL.Variables.Default;
with ASF.Contexts.Writer.Tests;
with Ada.Directories;
with Util.Tests;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use AUnit;
   use Ada.Strings.Unbounded;
   use ASF.Contexts.Writer.Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      App.Initialize (Conf);

      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
--              Writer    : aliased Test_Writer;
--              Context   : aliased Faces_Context;
--              View      : Components.Core.UIViewRoot;
--              ELContext : aliased EL.Contexts.Default.Default_Context;
--              Variables : aliased Default_Variable_Mapper;
--              Resolver  : aliased Default_ELResolver;
         begin
--              Context.Set_Response_Writer (Writer'Unchecked_Access);
--              Context.Set_ELContext (ELContext'Unchecked_Access);
--              ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);
--              ELContext.Set_Resolver (Resolver'Unchecked_Access);
--              Writer.Initialize ("text/xml", "UTF-8", 16384);

--              Set_Current (Context'Unchecked_Access);
--              H.Restore_View (View_Name, Context, View);
--
--              H.Render_View (Context, View);
--              Writer.Flush;

            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Message_String is
   begin
      return Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) = Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            File_Path : constant String := Full_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String (File_Path);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

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

with Ada.Text_IO;
with ASF.Applications.Main;
with ASF.Applications.Views;
with ASF.Components.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with EL.Contexts;
with EL.Contexts.Default;
with EL.Variables.Default;
with ASF.Contexts.Writer.Tests;
with Ada.Directories;
with Util.Tests;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use AUnit;
   use Ada.Strings.Unbounded;
   use ASF.Contexts.Writer.Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      use EL.Contexts.Default;
      use EL.Variables;
      use EL.Variables.Default;
      use EL.Contexts;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
   begin
      Conf.Load_Properties ("regtests/view.properties");
      App.Initialize (Conf, App_Factory);

      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin

            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Message_String is
   begin
      return Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) = Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            File_Path : constant String := Full_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String (File_Path);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

fix the unit test and cleanup

fix the unit test and cleanup


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2020 onox <denkpadje@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 GL.Context;
with GL.Viewports;

with Orka.Loggers;
with Orka.Logging;

with EGL.Debug;
with EGL.Errors;

package body Orka.Contexts.EGL is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Window_System);

   procedure Print_Error
     (Error : Standard.EGL.Errors.Error_Code;
      Level : Standard.EGL.Debug.Severity;
      Command, Message : String)
   is
      package Debug renames Standard.EGL.Debug;

      Severity : constant Orka.Loggers.Severity :=
        (case Level is
           when Debug.Critical => Loggers.Error,
           when Debug.Error    => Loggers.Error,
           when Debug.Warning  => Loggers.Warning,
           when Debug.Info     => Loggers.Debug);
   begin
      Messages.Log (Severity, Error'Image & " in " & Command & ": " & Trim (Message));
   end Print_Error;

   procedure Print_Debug
     (Display : Standard.EGL.Objects.Displays.Display;
      Flags   : Context_Flags) is
   begin
      Messages.Log (Debug, "Created EGL context");
      Messages.Log (Debug, "  platform: " & Display.Platform'Image);
      declare
         Name : constant String := Display.Device.Name;
      begin
         Messages.Log (Debug, "  device:   " & (if Name /= "" then Name else "unknown"));
      end;
      Messages.Log (Debug, "  vendor:   " & Display.Vendor);
      Messages.Log (Debug, "  version:  " & Display.Version);
      Messages.Log (Debug, "  context:");
      Messages.Log (Debug, "    flags:    " & Image (Flags));
      Messages.Log (Debug, "    version:  " & GL.Context.Version_String);
      Messages.Log (Debug, "    renderer: " & GL.Context.Renderer);
   end Print_Debug;

   procedure Post_Initialize (Object : in out EGL_Context'Class) is
      Flags : constant GL.Context.Context_Flags := GL.Context.Flags;
   begin
      Object.Version :=
        (Major => GL.Context.Major_Version,
         Minor => GL.Context.Minor_Version);

      pragma Assert (Flags.Forward_Compatible);

      Object.Flags.Debug    := Flags.Debug;
      Object.Flags.Robust   := Flags.Robust_Access;
      Object.Flags.No_Error := Flags.No_Error;
      --  Other information about context can be read back as well with
      --  GL.Context.Reset_Notification and GL.Context.Release_Behavior

      GL.Viewports.Set_Clipping (GL.Viewports.Lower_Left, GL.Viewports.Zero_To_One);
      Object.Vertex_Array.Create;
   end Post_Initialize;

   function Create_Context
     (Device   : Standard.EGL.Objects.Devices.Device;
      Version  : Context_Version;
      Flags    : Context_Flags := (others => False)) return Device_EGL_Context
   is
      package EGL_Contexts renames Standard.EGL.Objects.Contexts;
      package EGL_Displays renames Standard.EGL.Objects.Displays;
   begin
      Standard.EGL.Debug.Set_Message_Callback (Print_Error'Access);

      declare
         Display : constant EGL_Displays.Display := EGL_Displays.Create_Display (Device);
      begin
         return Result : Device_EGL_Context do
            Result.Context := EGL_Contexts.Create_Context (Display, Version, Flags);

            Post_Initialize (Result);
            Print_Debug (Display, Flags);
         end return;
      end;
   end Create_Context;

   overriding
   function Create_Context
     (Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Device_EGL_Context
   is
      package EGL_Devices renames Standard.EGL.Objects.Devices;

      Devices : constant EGL_Devices.Device_List := EGL_Devices.Devices;
   begin
      Messages.Log (Debug, "EGL devices:");
      for Device of Devices loop
         declare
            Name : constant String := Device.Name;
         begin
            Messages.Log (Debug, "  - " & (if Name /= "" then Name else "unknown"));
         end;
      end loop;

      return Create_Context (Devices (Devices'First), Version, Flags);
   end Create_Context;

   overriding
   function Create_Context
     (Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Wayland_EGL_Context is
   begin
      return Result : constant Wayland_EGL_Context :=
        (Ada.Finalization.Limited_Controlled with others => <>)
      do
         --  EGL context for Wayland platform requires a pointer to a native
         --  Wayland display
         raise Program_Error;
      end return;
   end Create_Context;

   function Create_Context
     (Window  : Standard.EGL.Native_Display_Ptr;
      Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Wayland_EGL_Context
   is
      package EGL_Contexts renames Standard.EGL.Objects.Contexts;
      package EGL_Displays renames Standard.EGL.Objects.Displays;
   begin
      Standard.EGL.Debug.Set_Message_Callback (Print_Error'Access);

      declare
         Display : constant EGL_Displays.Display := EGL_Displays.Create_Display (Window);
      begin
         return Result : Wayland_EGL_Context do
            Result.Context := EGL_Contexts.Create_Context (Display, Version, Flags);

            Result.Context.Make_Current;

            Post_Initialize (Result);
            Print_Debug (Display, Flags);
         end return;
      end;
   end Create_Context;

   overriding
   procedure Finalize (Object : in out EGL_Context) is
   begin
      if Object.Flags.Debug then
         Messages.Log (Debug, "Shutting down EGL");
      end if;

      Object.Vertex_Array.Delete;
   end Finalize;

   overriding
   procedure Enable (Object : in out EGL_Context; Subject : Feature) is
   begin
      Contexts.Enable (Object.Features, Subject);
   end Enable;

   overriding
   function Enabled (Object : EGL_Context; Subject : Feature) return Boolean
     is (Contexts.Enabled (Object.Features, Subject));

   overriding
   procedure Make_Current (Object : Device_EGL_Context) is
   begin
      Object.Context.Make_Current;
   end Make_Current;

   overriding
   procedure Make_Not_Current (Object : Device_EGL_Context) is
   begin
      Object.Context.Make_Not_Current;
   end Make_Not_Current;

   overriding
   procedure Make_Current (Object : Wayland_EGL_Context) is
   begin
      Object.Context.Make_Current;
   end Make_Current;

   overriding
   procedure Make_Not_Current (Object : Wayland_EGL_Context) is
   begin
      Object.Context.Make_Not_Current;
   end Make_Not_Current;

end Orka.Contexts.EGL;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2020 onox <denkpadje@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 GL.Context;
with GL.Viewports;

with Orka.Loggers;
with Orka.Logging;

with EGL.Debug;
with EGL.Errors;

package body Orka.Contexts.EGL is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;
   use Orka.Logging;

   package Messages is new Orka.Logging.Messages (Window_System);

   procedure Print_Error
     (Error : Standard.EGL.Errors.Error_Code;
      Level : Standard.EGL.Debug.Severity;
      Command, Message : String)
   is
      package Debug renames Standard.EGL.Debug;

      Severity : constant Orka.Loggers.Severity :=
        (case Level is
           when Debug.Critical => Loggers.Error,
           when Debug.Error    => Loggers.Error,
           when Debug.Warning  => Loggers.Warning,
           when Debug.Info     => Loggers.Debug);
   begin
      Messages.Log (Severity, Error'Image & " in " & Command & ": " & Trim (Message));
   end Print_Error;

   procedure Print_Debug
     (Display : Standard.EGL.Objects.Displays.Display;
      Flags   : Context_Flags) is
   begin
      Messages.Log (Debug, "Created EGL context");
      Messages.Log (Debug, "  platform: " & Display.Platform'Image);
      declare
         Name : constant String := Display.Device.Name;
      begin
         Messages.Log (Debug, "  device:   " & (if Name /= "" then Name else "unknown"));
      end;
      Messages.Log (Debug, "  vendor:   " & Display.Vendor);
      Messages.Log (Debug, "  version:  " & Display.Version);
      Messages.Log (Debug, "  context:");
      Messages.Log (Debug, "    flags:    " & Image (Flags));
      Messages.Log (Debug, "    version:  " & GL.Context.Version_String);
      Messages.Log (Debug, "    renderer: " & GL.Context.Renderer);
   end Print_Debug;

   procedure Post_Initialize (Object : in out EGL_Context'Class) is
      Flags : constant GL.Context.Context_Flags := GL.Context.Flags;
   begin
      Object.Version :=
        (Major => GL.Context.Major_Version,
         Minor => GL.Context.Minor_Version);

      pragma Assert (Flags.Forward_Compatible);

      Object.Flags.Debug    := Flags.Debug;
      Object.Flags.Robust   := Flags.Robust_Access;
      Object.Flags.No_Error := Flags.No_Error;
      --  Other information about context can be read back as well with
      --  GL.Context.Reset_Notification and GL.Context.Release_Behavior

      GL.Viewports.Set_Clipping (GL.Viewports.Lower_Left, GL.Viewports.Zero_To_One);
      Object.Vertex_Array.Create;
   end Post_Initialize;

   function Create_Context
     (Device   : Standard.EGL.Objects.Devices.Device;
      Version  : Context_Version;
      Flags    : Context_Flags := (others => False)) return Device_EGL_Context
   is
      package EGL_Contexts renames Standard.EGL.Objects.Contexts;
      package EGL_Displays renames Standard.EGL.Objects.Displays;
   begin
      Standard.EGL.Debug.Set_Message_Callback (Print_Error'Access);

      declare
         Display : constant EGL_Displays.Display := EGL_Displays.Create_Display (Device);
      begin
         return Result : Device_EGL_Context do
            Result.Context := EGL_Contexts.Create_Context (Display, Version, Flags);

            Result.Context.Make_Current;

            Post_Initialize (Result);
            Print_Debug (Display, Flags);
         end return;
      end;
   end Create_Context;

   overriding
   function Create_Context
     (Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Device_EGL_Context
   is
      package EGL_Devices renames Standard.EGL.Objects.Devices;

      Devices : constant EGL_Devices.Device_List := EGL_Devices.Devices;
   begin
      Messages.Log (Debug, "EGL devices:");
      for Device of Devices loop
         declare
            Name : constant String := Device.Name;
         begin
            Messages.Log (Debug, "  - " & (if Name /= "" then Name else "unknown"));
         end;
      end loop;

      return Create_Context (Devices (Devices'First), Version, Flags);
   end Create_Context;

   overriding
   function Create_Context
     (Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Wayland_EGL_Context is
   begin
      return Result : constant Wayland_EGL_Context :=
        (Ada.Finalization.Limited_Controlled with others => <>)
      do
         --  EGL context for Wayland platform requires a pointer to a native
         --  Wayland display
         raise Program_Error;
      end return;
   end Create_Context;

   function Create_Context
     (Window  : Standard.EGL.Native_Display_Ptr;
      Version : Context_Version;
      Flags   : Context_Flags := (others => False)) return Wayland_EGL_Context
   is
      package EGL_Contexts renames Standard.EGL.Objects.Contexts;
      package EGL_Displays renames Standard.EGL.Objects.Displays;
   begin
      Standard.EGL.Debug.Set_Message_Callback (Print_Error'Access);

      declare
         Display : constant EGL_Displays.Display := EGL_Displays.Create_Display (Window);
      begin
         return Result : Wayland_EGL_Context do
            Result.Context := EGL_Contexts.Create_Context (Display, Version, Flags);

            Result.Context.Make_Current;

            Post_Initialize (Result);
            Print_Debug (Display, Flags);
         end return;
      end;
   end Create_Context;

   overriding
   procedure Finalize (Object : in out EGL_Context) is
   begin
      if Object.Flags.Debug then
         Messages.Log (Debug, "Shutting down EGL");
      end if;

      Object.Vertex_Array.Delete;
   end Finalize;

   overriding
   procedure Enable (Object : in out EGL_Context; Subject : Feature) is
   begin
      Contexts.Enable (Object.Features, Subject);
   end Enable;

   overriding
   function Enabled (Object : EGL_Context; Subject : Feature) return Boolean
     is (Contexts.Enabled (Object.Features, Subject));

   overriding
   procedure Make_Current (Object : Device_EGL_Context) is
   begin
      Object.Context.Make_Current;
   end Make_Current;

   overriding
   procedure Make_Not_Current (Object : Device_EGL_Context) is
   begin
      Object.Context.Make_Not_Current;
   end Make_Not_Current;

   overriding
   procedure Make_Current (Object : Wayland_EGL_Context) is
   begin
      Object.Context.Make_Current;
   end Make_Current;

   overriding
   procedure Make_Not_Current (Object : Wayland_EGL_Context) is
   begin
      Object.Context.Make_Not_Current;
   end Make_Not_Current;

end Orka.Contexts.EGL;

orka: Fix reading back GL state if EGL context uses 'device' platform

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>