-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  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 AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
with Action_Bean;
with Ada.Text_IO;
with Ada.Strings.Unbounded;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;
   use Ada.Strings.Unbounded;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");

      declare
         E2 : constant Expression := E.Reduce_Expression (Context => T.Context);
         V2 : constant Object := E2.Get_Value (Context => T.Context);
      begin
         Assert (To_String (V2) = Expect,
                 "Reduce produced incorrect result: " & To_String (V2));
      end;
   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Simple_Evaluation (T : in out Test) is
   begin
      Check (T, "#{true}", "TRUE");
      Check (T, "#{false}", "FALSE");
      Check (T, "#{not false}", "TRUE");
      Check (T, "#{! false}", "TRUE");
      Check (T, "#{4 * 3}", "12");
      Check (T, "#{12 / 3}", "4");
      Check (T, "#{12 div 3}", "4");
      Check (T, "#{3 % 2}", "1");
      Check (T, "#{3 mod 2}", "1");
      Check (T, "#{3 > 4 ? 1 : 2}", "2");
      Check (T, "#{3 < 4 ? 1 : 2}", "1");
      Check (T, "#{true and false}", "FALSE");
      Check (T, "#{true or false}", "TRUE");
      Check (T, "#{- 23}", "-23");
      Check (T, "#{1.0}", "1");
      Check (T, "#{'\\''}", "'");
   end Test_Simple_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user ne null}", "TRUE");
      Check (T, "#{empty user}", "FALSE");
      Check (T, "#{not empty user}", "TRUE");
      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", "42");
      Check (T, "#{user.age le 42}", "TRUE");
      Check (T, "#{user.age lt 44}", "TRUE");
      Check (T, "#{user.age ge 42}", "TRUE");
      Check (T, "#{user.age ge 45}", "FALSE");
      Check (T, "#{user.age gt 42}", "FALSE");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", "43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "#{user.firstName eq 'Joe'}", "TRUE");
      Check (T, "#{user.firstName ne 'Joe'}", "FALSE");
      Check (T, "#{user.firstName eq 'Boe' or user.firstName eq 'Joe'}", "TRUE");
      Check (T, "Joe is #{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
      Check_Error (T, "#{12 > 23 ? 44}");
   end Test_Parse_Error;

   --  Test evaluation of method expression
   procedure Test_Method_Evaluation (T : in out Test) is
      use Action_Bean;

      A1 : constant Action_Access := new Action;
      A2 : constant Action_Access := new Action;
      P  : constant Person_Access := Create_Person ("Joe", "Black", 42);
      M  : EL.Expressions.Method_Expression :=
        Create_Expression (Context => T.Context,
                           Expr    => "#{action.notify}");
   begin
      T.Context.Set_Variable ("action", A1);
      Proc_Action.Execute (M, Person (P.all), T.Context);

      Assert (T, P.Last_Name = A1.Person.Last_Name, "Name was not set");

      P.Last_Name := To_Unbounded_String ("John");
      T.Context.Set_Variable ("action", A2);
      Proc_Action.Execute (M, Person (P.all), T.Context);

      Assert (T, "John" = A2.Person.Last_Name, "Name was not set");
   end Test_Method_Evaluation;

   --  Test evaluation of method expression
   procedure Test_Invalid_Method (T : in out Test) is
      use Action_Bean;

      A1 : constant Action_Access := new Action;
      A2 : constant Action_Access := new Action;
      P  : constant Person_Access := Create_Person ("Joe", "Black", 42);
      M2 : EL.Expressions.Method_Expression;
      M  : EL.Expressions.Method_Expression :=
        Create_Expression (Context => T.Context,
                           Expr    => "#{action.bar}");
   begin
      --  Bean is not found
      begin
         Proc_Action.Execute (M, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Variable exception was not raised");

      exception
         when EL.Expressions.Invalid_Variable =>
            null;
      end;

      T.Context.Set_Variable ("action", A1);
      begin
         Proc_Action.Execute (M, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Method exception was not raised");

      exception
         when EL.Expressions.Invalid_Method =>
            null;
      end;

      --  M2 is not initialized, this should raise Invalid_Expression
      begin
         Proc_Action.Execute (M2, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Method exception was not raised");

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;

      --  Create a method expression with an invalid expression
      begin
         M := Create_Expression ("#{12+13}", T.Context);
         Assert (T, False, "The Invalid_Expression exception was not raised");

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Test_Invalid_Method;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value (constant expressions)",
                                      Test_Simple_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Method_Info",
                                     Test_Method_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Method_Info (Invalid_method)",
                                     Test_Invalid_Method'Access));
   end Add_Tests;

end EL.Expressions.Tests;

-----------------------------------------------------------------------
--  EL testsuite - EL Testsuite
--  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 AUnit.Test_Caller;
with AUnit.Assertions;
with EL.Expressions;
with Test_Bean;
with Action_Bean;
with Ada.Text_IO;
with Ada.Strings.Unbounded;
package body EL.Expressions.Tests is

   use Test_Bean;
   use EL.Expressions;
   use AUnit.Assertions;
   use AUnit.Test_Fixtures;
   use Ada.Strings.Unbounded;

   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String);

   --  Check that evaluating an expression raises an exception
   procedure Check_Error (T    : in out Test'Class;
                          Expr : in String) is
      E : Expression;
   begin
      E := Create_Expression (Context => T.Context, Expr => Expr);

      pragma Unreferenced (E);
      Assert (Condition => False,
              Message => "Evaludation of '" & Expr & "' should raise an exception");
   exception
      when Invalid_Expression =>
         null;
   end Check_Error;

   --  Check that evaluating an expression returns the expected result
   --  (to keep the test simple, results are only checked using strings)
   procedure Check (T      : in out Test;
                    Expr   : in String;
                    Expect : in String) is
      E : constant Expression := Create_Expression (Context => T.Context,
                                                    Expr => Expr);
      V : constant Object := E.Get_Value (Context => T.Context);
   begin
      Assert (Condition => To_String (V) = Expect,
              Message => "Evaluate '" & Expr & "' returned '" & To_String (V)
              & "' when we expect '" & Expect & "'");

      declare
         E2 : constant Expression := E.Reduce_Expression (Context => T.Context);
         V2 : constant Object := E2.Get_Value (Context => T.Context);
      begin
         Assert (To_String (V2) = Expect,
                 "Reduce produced incorrect result: " & To_String (V2));
      end;
   end Check;

   --  Test evaluation of expression using a bean
   procedure Test_Simple_Evaluation (T : in out Test) is
   begin
      Check (T, "#{true}", "TRUE");
      Check (T, "#{false}", "FALSE");
      Check (T, "#{not false}", "TRUE");
      Check (T, "#{! false}", "TRUE");
      Check (T, "#{4 * 3}", "12");
      Check (T, "#{12 / 3}", "4");
      Check (T, "#{12 div 3}", "4");
      Check (T, "#{3 % 2}", "1");
      Check (T, "#{3 mod 2}", "1");
      Check (T, "#{3 <= 2}", "FALSE");
      Check (T, "#{3 < 2}", "FALSE");
      Check (T, "#{3 > 2}", "TRUE");
      Check (T, "#{3 >= 2}", "TRUE");
      Check (T, "#{3 >= 2 && 2 >= 3}", "FALSE");
      Check (T, "#{3 >= 4 || 2 < 3}", "TRUE");
      Check (T, "#{3 > 4 ? 1 : 2}", "2");
      Check (T, "#{3 < 4 ? 1 : 2}", "1");
      Check (T, "#{true and false}", "FALSE");
      Check (T, "#{true or false}", "TRUE");
      Check (T, "#{- 23}", "-23");
      Check (T, "#{1.0}", "1");
      Check (T, "#{'a\\'b'}", "'");
   end Test_Simple_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Bean_Evaluation (T : in out Test) is
      P : constant Person_Access := Create_Person ("Joe", "Black", 42);
   begin
      T.Context.Set_Variable ("user", P);

      Check (T, "#{user ne null}", "TRUE");
      Check (T, "#{empty user}", "FALSE");
      Check (T, "#{not empty user}", "TRUE");
      Check (T, "#{user.firstName}", "Joe");
      Check (T, "#{user.lastName}", "Black");
      Check (T, "#{user.age}", "42");
      Check (T, "#{user.age le 42}", "TRUE");
      Check (T, "#{user.age lt 44}", "TRUE");
      Check (T, "#{user.age ge 42}", "TRUE");
      Check (T, "#{user.age ge 45}", "FALSE");
      Check (T, "#{user.age gt 42}", "FALSE");
      Check (T, "#{user.date}", To_String (To_Object (P.Date)));
      Check (T, "#{user.weight}", To_String (To_Object (P.Weight)));

      P.Age := P.Age + 1;
      Check (T, "#{user.age}", "43");
      Check (T, "#{user.firstName & ' ' & user.lastName}", "Joe Black");

      Check (T, "#{user.firstName eq 'Joe'}", "TRUE");
      Check (T, "#{user.firstName ne 'Joe'}", "FALSE");
      Check (T, "#{user.firstName eq 'Boe' or user.firstName eq 'Joe'}", "TRUE");
      Check (T, "Joe is #{user.age} year#{user.age > 0 ? 's' : ''} old",
             "Joe is 43 years old");
   end Test_Bean_Evaluation;

   --  Test evaluation of expression using a bean
   procedure Test_Parse_Error (T : in out Test) is
   begin
      Check_Error (T, "#{1 +}");
      Check_Error (T, "#{12(}");
      Check_Error (T, "#{foo(1)}");
      Check_Error (T, "#{1+2+'abc}");
      Check_Error (T, "#{1+""}");
      Check_Error (T, "#{12");
      Check_Error (T, "${1");
      Check_Error (T, "test #{'}");
      Check_Error (T, "#{12 > 23 ? 44}");
      Check_Error (T, "#{");
      Check_Error (T, "${(12+1}");
      Check_Error (T, "#{'\\''}");
   end Test_Parse_Error;

   --  Test evaluation of method expression
   procedure Test_Method_Evaluation (T : in out Test) is
      use Action_Bean;

      A1 : constant Action_Access := new Action;
      A2 : constant Action_Access := new Action;
      P  : constant Person_Access := Create_Person ("Joe", "Black", 42);
      M  : EL.Expressions.Method_Expression :=
        Create_Expression (Context => T.Context,
                           Expr    => "#{action.notify}");
   begin
      T.Context.Set_Variable ("action", A1);
      Proc_Action.Execute (M, Person (P.all), T.Context);

      Assert (T, P.Last_Name = A1.Person.Last_Name, "Name was not set");

      P.Last_Name := To_Unbounded_String ("John");
      T.Context.Set_Variable ("action", A2);
      Proc_Action.Execute (M, Person (P.all), T.Context);

      Assert (T, "John" = A2.Person.Last_Name, "Name was not set");
   end Test_Method_Evaluation;

   --  Test evaluation of method expression
   procedure Test_Invalid_Method (T : in out Test) is
      use Action_Bean;

      A1 : constant Action_Access := new Action;
      A2 : constant Action_Access := new Action;
      P  : constant Person_Access := Create_Person ("Joe", "Black", 42);
      M2 : EL.Expressions.Method_Expression;
      M  : EL.Expressions.Method_Expression :=
        Create_Expression (Context => T.Context,
                           Expr    => "#{action.bar}");
   begin
      --  Bean is not found
      begin
         Proc_Action.Execute (M, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Variable exception was not raised");

      exception
         when EL.Expressions.Invalid_Variable =>
            null;
      end;

      T.Context.Set_Variable ("action", A1);
      begin
         Proc_Action.Execute (M, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Method exception was not raised");

      exception
         when EL.Expressions.Invalid_Method =>
            null;
      end;

      --  M2 is not initialized, this should raise Invalid_Expression
      begin
         Proc_Action.Execute (M2, Person (P.all), T.Context);
         Assert (T, False, "The Invalid_Method exception was not raised");

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;

      --  Create a method expression with an invalid expression
      begin
         M := Create_Expression ("#{12+13}", T.Context);
         Assert (T, False, "The Invalid_Expression exception was not raised");

      exception
         when EL.Expressions.Invalid_Expression =>
            null;
      end;
   end Test_Invalid_Method;

   package Caller is new AUnit.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value (constant expressions)",
                                      Test_Simple_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Contexts.Set_Variable",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Beans.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Value",
                                     Test_Bean_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Create_Expression (Parse Error)",
                                     Test_Parse_Error'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Method_Info",
                                     Test_Method_Evaluation'Access));
      Suite.Add_Test (Caller.Create ("Test EL.Expressions.Get_Method_Info (Invalid_method)",
                                     Test_Invalid_Method'Access));
   end Add_Tests;

end EL.Expressions.Tests;

Add new EL tests

Add new EL tests


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

with AWA.Workspaces.Models;
with AWA.Services.Contexts;
with AWA.Storages.Modules;
package body AWA.Images.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Load the list of images associated with the current folder.
   --  ------------------------------
   overriding
   procedure Load_Files (Storage : in Image_List_Bean) is
      use AWA.Services;

      Ctx       : constant ASC.Service_Context_Access := ASC.Current;
      User      : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session   : ADO.Sessions.Session := ASC.Get_Session (Ctx);
      Query     : ADO.Queries.Context;
   begin
      if not Storage.Init_Flags (AWA.Storages.Beans.INIT_FOLDER) then
         Load_Folder (Storage);
      end if;
      Query.Set_Query (AWA.Images.Models.Query_Image_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Workspaces.Models.WORKSPACE_TABLE, Session);
      if Storage.Folder_Bean.Is_Null then
         Query.Bind_Null_Param ("folder_id");
      else
         Query.Bind_Param ("folder_id", Storage.Folder_Bean.Get_Id);
      end if;
      AWA.Images.Models.List (Storage.Image_List_Bean.all, Session, Query);
      Storage.Flags (AWA.Storages.Beans.INIT_FILE_LIST) := True;
   end Load_Files;

   overriding
   function Get_Value (List : in Image_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "images" then
         return Util.Beans.Objects.To_Object (Value   => List.Image_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "folders" then
         return Util.Beans.Objects.To_Object (Value   => List.Folder_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "folder" then
--           if not List.Init_Flags (INIT_FOLDER) then
--              Load_Folder (List);
--           end if;
         if List.Folder_Bean.Is_Null then
            return Util.Beans.Objects.Null_Object;
         end if;
         return Util.Beans.Objects.To_Object (Value   => List.Folder_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Create the Image_List_Bean bean instance.
   --  ------------------------------
   function Create_Image_List_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      pragma Unreferenced (Module);

      Object    : constant Image_List_Bean_Access := new Image_List_Bean;
   begin
      Object.Module           := AWA.Storages.Modules.Get_Storage_Module;
      Object.Folder_Bean      := Object.Folder'Access;
      Object.Folder_List_Bean := Object.Folder_List'Access;
      Object.Files_List_Bean  := Object.Files_List'Access;
      Object.Image_List_Bean  := Object.Image_List'Access;
      Object.Flags            := Object.Init_Flags'Access;
      return Object.all'Access;
   end Create_Image_List_Bean;

   overriding
   procedure Load (Into    : in out Image_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type ADO.Identifier;

      Ctx     : constant ASC.Service_Context_Access := ASC.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session : ADO.Sessions.Session := ASC.Get_Session (Ctx);
      Query   : ADO.Queries.Context;
   begin
      if Into.Id = ADO.NO_IDENTIFIER then
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
         return;
      end if;

      --  Get the image information.
      Query.Set_Query (AWA.Images.Models.Query_Image_Info);
      Query.Bind_Param (Name => "user_id", Value => User);
      Query.Bind_Param (Name => "file_id", Value => Into.Id);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Workspaces.Models.WORKSPACE_TABLE, Session);
      Into.Load (Session, Query);

   exception
      when ADO.Objects.NOT_FOUND =>
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");

   end Load;

   --  ------------------------------
   --  Create the Image_Bean bean instance.
   --  ------------------------------
   function Create_Image_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                               return Util.Beans.Basic.Readonly_Bean_Access is
      Object    : constant Image_Bean_Access := new Image_Bean;
   begin
      Object.Module  := Module;
      Object.Id      := ADO.NO_IDENTIFIER;
      return Object.all'Access;
   end Create_Image_Bean;

end AWA.Images.Beans;

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

with AWA.Workspaces.Models;
with AWA.Services.Contexts;
with AWA.Storages.Modules;
package body AWA.Images.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Load the list of images associated with the current folder.
   --  ------------------------------
   overriding
   procedure Load_Files (Storage : in Image_List_Bean) is
      Ctx       : constant ASC.Service_Context_Access := ASC.Current;
      User      : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session   : ADO.Sessions.Session := ASC.Get_Session (Ctx);
      Query     : ADO.Queries.Context;
   begin
      if not Storage.Init_Flags (AWA.Storages.Beans.INIT_FOLDER) then
         Load_Folder (Storage);
      end if;
      Query.Set_Query (AWA.Images.Models.Query_Image_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Workspaces.Models.WORKSPACE_TABLE, Session);
      if Storage.Folder_Bean.Is_Null then
         Query.Bind_Null_Param ("folder_id");
      else
         Query.Bind_Param ("folder_id", Storage.Folder_Bean.Get_Id);
      end if;
      AWA.Images.Models.List (Storage.Image_List_Bean.all, Session, Query);
      Storage.Flags (AWA.Storages.Beans.INIT_FILE_LIST) := True;
   end Load_Files;

   overriding
   function Get_Value (List : in Image_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "images" then
         return Util.Beans.Objects.To_Object (Value   => List.Image_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "folders" then
         return Util.Beans.Objects.To_Object (Value   => List.Folder_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "folder" then
--           if not List.Init_Flags (INIT_FOLDER) then
--              Load_Folder (List);
--           end if;
         if List.Folder_Bean.Is_Null then
            return Util.Beans.Objects.Null_Object;
         end if;
         return Util.Beans.Objects.To_Object (Value   => List.Folder_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Create the Image_List_Bean bean instance.
   --  ------------------------------
   function Create_Image_List_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                                    return Util.Beans.Basic.Readonly_Bean_Access is
      pragma Unreferenced (Module);

      Object    : constant Image_List_Bean_Access := new Image_List_Bean;
   begin
      Object.Module           := AWA.Storages.Modules.Get_Storage_Module;
      Object.Folder_Bean      := Object.Folder'Access;
      Object.Folder_List_Bean := Object.Folder_List'Access;
      Object.Files_List_Bean  := Object.Files_List'Access;
      Object.Image_List_Bean  := Object.Image_List'Access;
      Object.Flags            := Object.Init_Flags'Access;
      return Object.all'Access;
   end Create_Image_List_Bean;

   overriding
   procedure Load (Into    : in out Image_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type ADO.Identifier;

      Ctx     : constant ASC.Service_Context_Access := ASC.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Session : ADO.Sessions.Session := ASC.Get_Session (Ctx);
      Query   : ADO.Queries.Context;
   begin
      if Into.Id = ADO.NO_IDENTIFIER then
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");
         return;
      end if;

      --  Get the image information.
      Query.Set_Query (AWA.Images.Models.Query_Image_Info);
      Query.Bind_Param (Name => "user_id", Value => User);
      Query.Bind_Param (Name => "file_id", Value => Into.Id);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Workspaces.Models.WORKSPACE_TABLE, Session);
      Into.Load (Session, Query);

   exception
      when ADO.Objects.NOT_FOUND =>
         Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("not-found");

   end Load;

   --  ------------------------------
   --  Create the Image_Bean bean instance.
   --  ------------------------------
   function Create_Image_Bean (Module : in AWA.Images.Modules.Image_Module_Access)
                               return Util.Beans.Basic.Readonly_Bean_Access is
      Object    : constant Image_Bean_Access := new Image_Bean;
   begin
      Object.Module  := Module;
      Object.Id      := ADO.NO_IDENTIFIER;
      return Object.all'Access;
   end Create_Image_Bean;

end AWA.Images.Beans;

Fix compilation warning

Fix compilation warning


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

with Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      AWA.Tests.Helpers.Users.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         AWA.Tests.Helpers.Users.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : AWA.Tests.Helpers.Users.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         AWA.Tests.Helpers.Users.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      AWA.Tests.Helpers.Users.Create_User (Principal);
      AWA.Tests.Helpers.Users.Logout (Principal);

      AWA.Tests.Helpers.Users.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         --  Storing a date in the database will loose some precision.
         T.Assert (S1.Get_Start_Date.Value >= T1 - 1.0, "Start date is invalid 1");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type AWA.Users.Principals.Principal_Access;

      Principal : AWA.Tests.Helpers.Users.Test_User;
      Key       : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      AWA.Tests.Helpers.Users.Create_User (Principal);
      AWA.Tests.Helpers.Users.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      AWA.Tests.Helpers.Users.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key       => Key.Get_Access_Key,
                                           Password  => "newadmin",
                                           IpAddr    => "192.168.1.2",
                                           Principal => Principal.Principal);
         T.Assert (Principal.Principal /= null, "No principal returned");

         Principal.User    := Principal.Principal.Get_User;
         Principal.Session := Principal.Principal.Get_Session;

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      AWA.Tests.Helpers.Users.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Modules.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Modules.User_Module_Access := AWA.Users.Modules.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Modules.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Modules.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

Fix indentation

Fix indentation


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

with Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;
   use type Util.Systems.Types.File_Type;
   use type Ada.Directories.File_Kind;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

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

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

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

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   procedure Prepare_Working_Directory (Sys : in out System_Process;
                                        Proc : in out Process'Class) is
      Dir : constant String := Ada.Strings.Unbounded.To_String (Proc.Dir);
   begin
      Interfaces.C.Strings.Free (Sys.Dir);
      if Dir'Length > 0 then
         if not Ada.Directories.Exists (Dir)
           or else Ada.Directories.Kind (Dir) /= Ada.Directories.Directory
         then
            raise Ada.Directories.Name_Error with "Invalid directory: " & Dir;
         end if;
         Sys.Dir := Interfaces.C.Strings.New_String (Dir);
      end if;
   end Prepare_Working_Directory;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      Sys.Prepare_Working_Directory (Proc);

      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.

         if Proc.To_Close /= null then
            for Fd of Proc.To_Close.all loop
               Result := Sys_Close (Fd);
            end loop;
         end if;

         --  Handle stdin/stdout/stderr pipe redirections unless they are file-redirected.

         if Sys.Err_File = Null_Ptr and Stdout_Pipes (1) /= NO_FILE then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         --  Redirect stdin to the pipe unless we use file redirection.
         if Sys.In_File = Null_Ptr and Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
            end if;
         end if;
         if Stdin_Pipes (0) /= NO_FILE and Stdin_Pipes (0) /= STDIN_FILENO then
            Result := Sys_Close (Stdin_Pipes (0));
         end if;
         if Stdin_Pipes (1) /= NO_FILE then
            Result := Sys_Close (Stdin_Pipes (1));
         end if;

         --  Redirect stdout to the pipe unless we use file redirection.
         if Sys.Out_File = Null_Ptr and Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
            end if;
         end if;
         if Stdout_Pipes (1) /= NO_FILE and Stdout_Pipes (1) /= STDOUT_FILENO then
            Result := Sys_Close (Stdout_Pipes (1));
         end if;
         if Stdout_Pipes (0) /= NO_FILE then
            Result := Sys_Close (Stdout_Pipes (0));
         end if;

         if Sys.Err_File = Null_Ptr and Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));
         end if;

         if Sys.In_File /= Null_Ptr then
            --  Redirect the process input from a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.In_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDIN_FILENO then
                  Result := Sys_Dup2 (Fd, STDIN_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDOUT_FILENO then
                  Result := Sys_Dup2 (Fd, STDOUT_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDERR_FILENO then
                  Result := Sys_Dup2 (Fd, STDERR_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Dir /= Null_Ptr then
            Result := Sys_Chdir (Sys.Dir);
            if Result < 0 then
               Sys_Exit (253);
            end if;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access) is
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
      Sys.To_Close := To_Close;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
      Interfaces.C.Strings.Free (Sys.Dir);
   end Finalize;

end Util.Processes.Os;

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

with Ada.Directories;
with Ada.Unchecked_Deallocation;

package body Util.Processes.Os is

   use Util.Systems.Os;
   use type Interfaces.C.size_t;
   use type Util.Systems.Types.File_Type;
   use type Ada.Directories.File_Kind;

   type Pipe_Type is array (0 .. 1) of File_Type;
   procedure Close (Pipes : in out Pipe_Type);

   --  ------------------------------
   --  Create the output stream to read/write on the process input/output.
   --  Setup the file to be closed on exec.
   --  ------------------------------
   function Create_Stream (File : in File_Type)
                           return Util.Streams.Raw.Raw_Stream_Access is
      Stream : constant Util.Streams.Raw.Raw_Stream_Access := new Util.Streams.Raw.Raw_Stream;
      Status : constant Integer := Sys_Fcntl (File, F_SETFL, FD_CLOEXEC);
      pragma Unreferenced (Status);
   begin
      Stream.Initialize (File);
      return Stream;
   end Create_Stream;

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

      use type Util.Streams.Output_Stream_Access;

      Result : Integer;
      Wpid   : Integer;
   begin
      --  Close the input stream pipe if there is one.
      if Proc.Input /= null then
         Util.Streams.Raw.Raw_Stream'Class (Proc.Input.all).Close;
      end if;

      Wpid := Sys_Waitpid (Integer (Proc.Pid), Result'Address, 0);
      if Wpid = Integer (Proc.Pid) then
         Proc.Exit_Value := Result / 256;
         if Result mod 256 /= 0 then
            Proc.Exit_Value := (Result mod 256) * 1000;
         end if;
      end if;
   end Wait;

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

   --  ------------------------------
   --  Close both ends of the pipe (used to cleanup in case or error).
   --  ------------------------------
   procedure Close (Pipes : in out Pipe_Type) is
      Result : Integer;
      pragma Unreferenced (Result);
   begin
      if Pipes (0) /= NO_FILE then
         Result := Sys_Close (Pipes (0));
         Pipes (0) := NO_FILE;
      end if;
      if Pipes (1) /= NO_FILE then
         Result := Sys_Close (Pipes (1));
         Pipes (1) := NO_FILE;
      end if;
   end Close;

   procedure Prepare_Working_Directory (Sys : in out System_Process;
                                        Proc : in out Process'Class) is
      Dir : constant String := Ada.Strings.Unbounded.To_String (Proc.Dir);
   begin
      Interfaces.C.Strings.Free (Sys.Dir);
      if Dir'Length > 0 then
         if not Ada.Directories.Exists (Dir)
           or else Ada.Directories.Kind (Dir) /= Ada.Directories.Directory
         then
            raise Ada.Directories.Name_Error with "Invalid directory: " & Dir;
         end if;
         Sys.Dir := Interfaces.C.Strings.New_String (Dir);
      end if;
   end Prepare_Working_Directory;

   --  ------------------------------
   --  Spawn a new process.
   --  ------------------------------
   overriding
   procedure Spawn (Sys  : in out System_Process;
                    Proc : in out Process'Class;
                    Mode : in Pipe_Mode := NONE) is
      use Interfaces.C.Strings;
      use type Interfaces.C.int;

      procedure Cleanup;

      --  Suppress all checks to make sure the child process will not raise any exception.
      pragma Suppress (All_Checks);

      Result : Integer;

      Stdin_Pipes   : aliased Pipe_Type := (others => NO_FILE);
      Stdout_Pipes  : aliased Pipe_Type := (others => NO_FILE);
      Stderr_Pipes  : aliased Pipe_Type := (others => NO_FILE);

      procedure Cleanup is
      begin
         Close (Stdin_Pipes);
         Close (Stdout_Pipes);
         Close (Stderr_Pipes);
      end Cleanup;

   begin
      Sys.Prepare_Working_Directory (Proc);

      --  Since checks are disabled, verify by hand that the argv table is correct.
      if Sys.Argv = null or else Sys.Argc < 1 or else Sys.Argv (0) = Null_Ptr then
         raise Program_Error with "Invalid process argument list";
      end if;

      --  Setup the pipes.
      if Mode = WRITE or Mode = READ_WRITE or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdin_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdin pipe";
         end if;
      end if;
      if Mode = READ or Mode = READ_WRITE or Mode = READ_ALL or Mode = READ_WRITE_ALL then
         if Sys_Pipe (Stdout_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stdout pipe";
         end if;
      end if;
      if Mode = READ_ERROR then
         if Sys_Pipe (Stderr_Pipes'Address) /= 0 then
            Cleanup;
            raise Process_Error with "Cannot create stderr pipe";
         end if;
      end if;

      --  Create the new process by using vfork instead of fork.  The parent process is blocked
      --  until the child executes the exec or exits.  The child process uses the same stack
      --  as the parent.
      Proc.Pid := Sys_VFork;
      if Proc.Pid = 0 then

         --  Do not use any Ada type while in the child process.

         if Proc.To_Close /= null then
            for Fd of Proc.To_Close.all loop
               Result := Sys_Close (Fd);
            end loop;
         end if;

         --  Handle stdin/stdout/stderr pipe redirections unless they are file-redirected.

         if Sys.Err_File = Null_Ptr and Stdout_Pipes (1) /= NO_FILE
           and (Mode = READ_ALL or Mode = READ_WRITE_ALL)
         then
            Result := Sys_Dup2 (Stdout_Pipes (1), STDERR_FILENO);
         end if;

         --  Redirect stdin to the pipe unless we use file redirection.
         if Sys.In_File = Null_Ptr and Stdin_Pipes (0) /= NO_FILE then
            if Stdin_Pipes (0) /= STDIN_FILENO then
               Result := Sys_Dup2 (Stdin_Pipes (0), STDIN_FILENO);
            end if;
         end if;
         if Stdin_Pipes (0) /= NO_FILE and Stdin_Pipes (0) /= STDIN_FILENO then
            Result := Sys_Close (Stdin_Pipes (0));
         end if;
         if Stdin_Pipes (1) /= NO_FILE then
            Result := Sys_Close (Stdin_Pipes (1));
         end if;

         --  Redirect stdout to the pipe unless we use file redirection.
         if Sys.Out_File = Null_Ptr and Stdout_Pipes (1) /= NO_FILE then
            if Stdout_Pipes (1) /= STDOUT_FILENO then
               Result := Sys_Dup2 (Stdout_Pipes (1), STDOUT_FILENO);
            end if;
         end if;
         if Stdout_Pipes (1) /= NO_FILE and Stdout_Pipes (1) /= STDOUT_FILENO then
            Result := Sys_Close (Stdout_Pipes (1));
         end if;
         if Stdout_Pipes (0) /= NO_FILE then
            Result := Sys_Close (Stdout_Pipes (0));
         end if;

         if Sys.Err_File = Null_Ptr and Stderr_Pipes (1) /= NO_FILE then
            if Stderr_Pipes (1) /= STDERR_FILENO then
               Result := Sys_Dup2 (Stderr_Pipes (1), STDERR_FILENO);
               Result := Sys_Close (Stderr_Pipes (1));
            end if;
            Result := Sys_Close (Stderr_Pipes (0));
         end if;

         if Sys.In_File /= Null_Ptr then
            --  Redirect the process input from a file.
            declare
               Fd : File_Type;
            begin
               Fd := Sys_Open (Sys.In_File, O_RDONLY, 8#644#);
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDIN_FILENO then
                  Result := Sys_Dup2 (Fd, STDIN_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Out_File /= Null_Ptr then
            --  Redirect the process output to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Out_Append then
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Out_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDOUT_FILENO then
                  Result := Sys_Dup2 (Fd, STDOUT_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Err_File /= Null_Ptr then
            --  Redirect the process error to a file.
            declare
               Fd : File_Type;
            begin
               if Sys.Err_Append then
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_APPEND, 8#644#);
               else
                  Fd := Sys_Open (Sys.Err_File, O_CREAT + O_WRONLY + O_TRUNC, 8#644#);
               end if;
               if Fd < 0 then
                  Sys_Exit (254);
               end if;
               if Fd /= STDERR_FILENO then
                  Result := Sys_Dup2 (Fd, STDERR_FILENO);
                  Result := Sys_Close (Fd);
               end if;
            end;
         end if;

         if Sys.Dir /= Null_Ptr then
            Result := Sys_Chdir (Sys.Dir);
            if Result < 0 then
               Sys_Exit (253);
            end if;
         end if;

         Result := Sys_Execvp (Sys.Argv (0), Sys.Argv.all);
         Sys_Exit (255);
      end if;

      --  Process creation failed, cleanup and raise an exception.
      if Proc.Pid < 0 then
         Cleanup;
         raise Process_Error with "Cannot create process";
      end if;

      if Stdin_Pipes (1) /= NO_FILE then
         Result := Sys_Close (Stdin_Pipes (0));
         Proc.Input := Create_Stream (Stdin_Pipes (1)).all'Access;
      end if;

      if Stdout_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stdout_Pipes (1));
         Proc.Output := Create_Stream (Stdout_Pipes (0)).all'Access;
      end if;

      if Stderr_Pipes (0) /= NO_FILE then
         Result := Sys_Close (Stderr_Pipes (1));
         Proc.Error := Create_Stream (Stderr_Pipes (0)).all'Access;
      end if;

   end Spawn;

   procedure Free is
     new Ada.Unchecked_Deallocation (Name => Ptr_Ptr_Array, Object => Ptr_Array);

   --  ------------------------------
   --  Append the argument to the process argument list.
   --  ------------------------------
   overriding
   procedure Append_Argument (Sys : in out System_Process;
                              Arg : in String) is
   begin
      if Sys.Argv = null then
         Sys.Argv := new Ptr_Array (0 .. 10);
      elsif Sys.Argc = Sys.Argv'Last - 1 then
         declare
            N : constant Ptr_Ptr_Array := new Ptr_Array (0 .. Sys.Argc + 32);
         begin
            N (0 .. Sys.Argc) := Sys.Argv (0 .. Sys.Argc);
            Free (Sys.Argv);
            Sys.Argv := N;
         end;
      end if;

      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.New_String (Arg);
      Sys.Argc := Sys.Argc + 1;
      Sys.Argv (Sys.Argc) := Interfaces.C.Strings.Null_Ptr;
   end Append_Argument;

   --  ------------------------------
   --  Set the process input, output and error streams to redirect and use specified files.
   --  ------------------------------
   overriding
   procedure Set_Streams (Sys           : in out System_Process;
                          Input         : in String;
                          Output        : in String;
                          Error         : in String;
                          Append_Output : in Boolean;
                          Append_Error  : in Boolean;
                          To_Close      : in File_Type_Array_Access) is
   begin
      if Input'Length > 0 then
         Sys.In_File := Interfaces.C.Strings.New_String (Input);
      end if;
      if Output'Length > 0 then
         Sys.Out_File   := Interfaces.C.Strings.New_String (Output);
         Sys.Out_Append := Append_Output;
      end if;
      if Error'Length > 0 then
         Sys.Err_File   := Interfaces.C.Strings.New_String (Error);
         Sys.Err_Append := Append_Error;
      end if;
      Sys.To_Close := To_Close;
   end Set_Streams;

   --  ------------------------------
   --  Deletes the storage held by the system process.
   --  ------------------------------
   overriding
   procedure Finalize (Sys : in out System_Process) is
   begin
      if Sys.Argv /= null then
         for I in Sys.Argv'Range loop
            Interfaces.C.Strings.Free (Sys.Argv (I));
         end loop;
         Free (Sys.Argv);
      end if;
      Interfaces.C.Strings.Free (Sys.In_File);
      Interfaces.C.Strings.Free (Sys.Out_File);
      Interfaces.C.Strings.Free (Sys.Err_File);
      Interfaces.C.Strings.Free (Sys.Dir);
   end Finalize;

end Util.Processes.Os;

Fix READ pipe mode which was also redirecting the standard error


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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

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

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   GOOGLE_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   GOOGLE_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.google.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   G_NAME       : aliased constant String := "google+";
   G_GENERATOR  : aliased Google_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (G_NAME'Access, G_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Google like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Google_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (Generator);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (GOOGLE_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (GOOGLE_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Include_Script ("https://apis.google.com/js/plusone.js");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "g-plusone");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, GOOGLE_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

Implement the Google like generator

Implement the Google like generator


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

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean);

end AWA.Applications.Configs;

-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012, 2015, 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 EL.Contexts.Default;
with Util.Serialize.IO.XML;

--  The <b>AWA.Applications.Configs</b> package reads the application configuration files.
package AWA.Applications.Configs is

   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      App     : in Application_Access;
      Context : in EL.Contexts.Default.Default_Context_Access;
      Override_Context : in Boolean;
   package Reader_Config is
   end Reader_Config;

   --  Read the application configuration file and configure the application
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean);

   --  Get the configuration path for the application name.
   --  The configuration path is search from:
   --  o the current directory,
   --  o the 'config' directory,
   --  o the Dynamo installation directory in share/dynamo
   function Get_Config_Path (Name : in String) return String;

end AWA.Applications.Configs;

Declare the Get_Config_Path function to retrieve a configuration file path


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

with Util.Tests;
with AWA.Tests;
with Servlet.requests.Mockup;
with Servlet.Responses.Mockup;
with Ada.Strings.Unbounded;

package AWA.Images.Tests is

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

   type Test is new AWA.Tests.Test with record
      Folder_Ident  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the image as anonymous users.
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String);

   --  Verify that the image lists contain the given image.
   procedure Verify_List_Contains (T    : in out Test;
                                   Name : in String);

   --  Test access to the image as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of image by simulating web requests.
   procedure Test_Create_Image (T : in out Test);

   --  Test getting an image which does not exist.
   procedure Test_Missing_Image (T : in out Test);

end AWA.Images.Tests;

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

with Util.Tests;
with AWA.Tests;
with Ada.Strings.Unbounded;

package AWA.Images.Tests is

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

   type Test is new AWA.Tests.Test with record
      Folder_Ident  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the image as anonymous users.
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String);

   --  Verify that the image lists contain the given image.
   procedure Verify_List_Contains (T    : in out Test;
                                   Name : in String);

   --  Test access to the image as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of image by simulating web requests.
   procedure Test_Create_Image (T : in out Test);

   --  Test getting an image which does not exist.
   procedure Test_Missing_Image (T : in out Test);

end AWA.Images.Tests;

Remove unused with clause (moved to the body)