-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  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.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is new Util.Serialize.IO.JSON.Parser with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

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

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

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

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse_String (Content);
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

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

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
   end Read_JSON;

end Util.Properties.JSON;

-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  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.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is new Util.Serialize.IO.JSON.Parser with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

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

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

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

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse_String (Content);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

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

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

Raise a Parse_Error exception if there is an error while parsing the JSON content


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

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Workspaces.Module");

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

   --  ------------------------------
   --  Initialize the workspaces module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the workspaces module");

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session => Session,
                                               User    => User.Get_Id,
                                               Entity  => WS);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      Ctx   : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User  : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS    : AWA.Workspaces.Models.Workspace_Ref;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Log.Info ("Sending invitation to {0}", String '(Invitation.Get_Email));

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      --  Key.Set_Key_Value
      Key.Save (DB);
      Invitation.Set_Inviter (User);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);
      Ctx.Commit;
   end Send_Invitation;

end AWA.Workspaces.Modules;

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

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Workspaces.Module");

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

   --  ------------------------------
   --  Initialize the workspaces module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the workspaces module");

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session => Session,
                                               User    => User.Get_Id,
                                               Entity  => WS);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      Ctx   : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User  : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS    : AWA.Workspaces.Models.Workspace_Ref;
      Query : ADO.SQL.Query;
      Found : Boolean;
      Key   : AWA.Users.Models.Access_Key_Ref;
   begin
      Log.Info ("Sending invitation to {0}", String '(Invitation.Get_Email));

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      Module.User_Manager.Create_Access_Key (User, Key, 365 * 86400.0, DB);
      Key.Save (DB);
      Invitation.Set_Inviter (User);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);
      Ctx.Commit;
   end Send_Invitation;

end AWA.Workspaces.Modules;

Create the invitation access key

Create the invitation access key


-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 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 ADO.Sessions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;
   end record;

end AWA.Workspaces.Modules;

-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 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 ADO.Objects;
with ADO.Sessions;

with Security.Permissions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
private with Ada.Strings.Unbounded;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   subtype Permission_Index_Array is Security.Permissions.Permission_Index_Array;

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   --  The configuration parameter that defines the list of permissions to grant
   --  to a user when his workspace is created.
   PARAM_PERMISSIONS_LIST : constant String := "permissions_list";

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Workspace_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the list of permissions for the workspace owner.
   function Get_Owner_Permissions (Manager : in Workspace_Module) return Permission_Index_Array;

   --  Get the workspace module.
   function Get_Workspace_Module return Workspace_Module_Access;

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

   --  Add a list of permissions for all the users of the workspace that have the appropriate
   --  role.  Workspace members will be able to access the given database entity for the
   --  specified list of permissions.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             List       : in Security.Permissions.Permission_Index_Array);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;

      --  The list of permissions to grant to a user who creates the workspace.
      Owner_Permissions : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Workspaces.Modules;

Refactor the permission - Declare the PARAM_PERMISSIONS_LIST constant - Override the Configure procedure - Declare the Get_Owner_Permissions function - Declare Get_WorkspaceModule - Declare Add_Permission procedure


-----------------------------------------------------------------------
--  components-widgets-likes -- Social Likes Components
--  Copyright (C) 2013, 2014, 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 Util.Locales;
with Util.Beans.Objects;
with Util.Strings.Tokenizers;

--  GNAT bug, the with clause is necessary to call Get_Global on the application.
pragma Warnings (Off, "*is not referenced");
with ASF.Applications.Main;
pragma Warnings (On, "*is not referenced");

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";
   FB_SEND_ATTR        : aliased constant String := "data-send";

   TW_VIA_ATTR         : aliased constant String := "data-via";
   TW_COUNT_ATTR       : aliased constant String := "data-count";
   TW_SIZE_ATTR        : aliased constant String := "data-size";
   TW_COUNTURL_ATTR    : aliased constant String := "data-counturl";
   TW_TEXT_ATTR        : aliased constant String := "data-text";
   TW_RELATED_ATTR     : aliased constant String := "data-related";
   TW_LANG_ATTR        : aliased constant String := "data-lang";
   TW_HASHTAGS_ATTR    : aliased constant String := "data-hashtags";

   G_ANNOTATION_ATTR   : aliased constant String := "data-annotation";
   G_WIDTH_ATTR        : aliased constant String := "data-width";

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

   TWITTER_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   TWITTER_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.twitter.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;

   TWITTER_NAME       : aliased constant String := "twitter";
   TWITTER_GENERATOR  : aliased Twitter_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (G_NAME'Access, G_GENERATOR'Access),
                                         3 => (TWITTER_NAME'Access, TWITTER_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
      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 (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.async=true;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=");
         declare
            App_Id : constant String
              := Context.Get_Application.Get_Config (P_Facebook_App_Id.P);
         begin
            if App_Id'Length = 0 then
               UI.Log_Error ("The facebook client application id is empty");
               UI.Log_Error ("Please, configure the '{0}' property "
                             & "in the application", P_Facebook_App_Id.PARAM_NAME);
            else
               Writer.Queue_Script (App_Id);
            end if;
         end;
         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);
      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);
      UI.Render_Attributes (Context, GOOGLE_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Tweeter like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Twitter_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;
      Lang    : constant String := Util.Locales.Get_ISO3_Language (Context.Get_Locale);
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (TWITTER_SCRIPT_ATTRIBUTE))
      then
         Request.Set_Attribute (TWITTER_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("!function(d,s,id){var js,fjs=d.getElementsByTagName(s)[0],"
                              & "p=/^http:/.test(d.location)?'http':'https';"
                              & "if(!d.getElementById(id)){js=d.createElement(s);js.id=id;"
                              & "js.src=p+'://platform.twitter.com/widgets.js';"
                              & "fjs.parentNode.insertBefore(js,fjs);}}"
                              & "(document, 'script', 'twitter-wjs');");
      end if;
      Writer.Start_Element ("a");
      Writer.Write_Attribute ("href", "https://twitter.com/share");
      Writer.Write_Attribute ("class", "twitter-share-button");
      Writer.Write_Attribute ("data-url", Href);
      Writer.Write_Attribute ("data-lang", Lang);
      UI.Render_Attributes (Context, TWITTER_ATTRIBUTE_NAMES, Writer);
      Writer.Write_Text ("Tweet");
      Writer.End_Element ("a");
   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
            Writer : constant Contexts.Writer.Response_Writer_Access
              := Context.Get_Response_Writer;
            Kind   : constant String := UI.Get_Attribute ("type", Context, "");
            Href   : constant String := UILike'Class (UI).Get_Link (Context);
            Style  : constant String := UI.Get_Attribute ("style", Context, "");
            Class  : constant String := UI.Get_Attribute ("styleClass", 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
                     Writer.Start_Element ("div");
                     if Style'Length > 0 then
                        Writer.Write_Attribute ("style", Style);
                     end if;
                     if Class'Length > 0 then
                        Writer.Write_Attribute ("class", Class);
                     end if;
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     Writer.End_Element ("div");
                     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);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SEND_ATTR'Access);

   TWITTER_ATTRIBUTE_NAMES.Insert (TW_SIZE_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_VIA_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNTURL_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_TEXT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_RELATED_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_LANG_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_HASHTAGS_ATTR'Access);

   GOOGLE_ATTRIBUTE_NAMES.Insert (G_ANNOTATION_ATTR'Access);
   GOOGLE_ATTRIBUTE_NAMES.Insert (G_WIDTH_ATTR'Access);
end ASF.Components.Widgets.Likes;

-----------------------------------------------------------------------
--  components-widgets-likes -- Social Likes Components
--  Copyright (C) 2013, 2014, 2015, 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 Util.Locales;
with Util.Beans.Objects;
with Util.Strings.Tokenizers;

--  GNAT bug, the with clause is necessary to call Get_Global on the application.
pragma Warnings (Off, "*is not referenced");
with ASF.Applications.Main;
pragma Warnings (On, "*is not referenced");

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";
   FB_SEND_ATTR        : aliased constant String := "data-send";

   TW_VIA_ATTR         : aliased constant String := "data-via";
   TW_COUNT_ATTR       : aliased constant String := "data-count";
   TW_SIZE_ATTR        : aliased constant String := "data-size";
   TW_COUNTURL_ATTR    : aliased constant String := "data-counturl";
   TW_TEXT_ATTR        : aliased constant String := "data-text";
   TW_RELATED_ATTR     : aliased constant String := "data-related";
   TW_LANG_ATTR        : aliased constant String := "data-lang";
   TW_HASHTAGS_ATTR    : aliased constant String := "data-hashtags";

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

   TWITTER_ATTRIBUTE_NAMES    : Util.Strings.String_Set.Set;
   TWITTER_SCRIPT_ATTRIBUTE   : constant String := "asf.widgets.twitter.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;

   TWITTER_NAME       : aliased constant String := "twitter";
   TWITTER_GENERATOR  : aliased Twitter_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         2 => (TWITTER_NAME'Access, TWITTER_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
      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 (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.async=true;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=");
         declare
            App_Id : constant String
              := Context.Get_Application.Get_Config (P_Facebook_App_Id.P);
         begin
            if App_Id'Length = 0 then
               UI.Log_Error ("The facebook client application id is empty");
               UI.Log_Error ("Please, configure the '{0}' property "
                             & "in the application", P_Facebook_App_Id.PARAM_NAME);
            else
               Writer.Queue_Script (App_Id);
            end if;
         end;
         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);
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Tweeter like generator
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Twitter_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;
      Lang    : constant String := Util.Locales.Get_ISO3_Language (Context.Get_Locale);
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (TWITTER_SCRIPT_ATTRIBUTE))
      then
         Request.Set_Attribute (TWITTER_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("!function(d,s,id){var js,fjs=d.getElementsByTagName(s)[0],"
                              & "p=/^http:/.test(d.location)?'http':'https';"
                              & "if(!d.getElementById(id)){js=d.createElement(s);js.id=id;"
                              & "js.src=p+'://platform.twitter.com/widgets.js';"
                              & "fjs.parentNode.insertBefore(js,fjs);}}"
                              & "(document, 'script', 'twitter-wjs');");
      end if;
      Writer.Start_Element ("a");
      Writer.Write_Attribute ("href", "https://twitter.com/share");
      Writer.Write_Attribute ("class", "twitter-share-button");
      Writer.Write_Attribute ("data-url", Href);
      Writer.Write_Attribute ("data-lang", Lang);
      UI.Render_Attributes (Context, TWITTER_ATTRIBUTE_NAMES, Writer);
      Writer.Write_Text ("Tweet");
      Writer.End_Element ("a");
   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
            Writer : constant Contexts.Writer.Response_Writer_Access
              := Context.Get_Response_Writer;
            Kind   : constant String := UI.Get_Attribute ("type", Context, "");
            Href   : constant String := UILike'Class (UI).Get_Link (Context);
            Style  : constant String := UI.Get_Attribute ("style", Context, "");
            Class  : constant String := UI.Get_Attribute ("styleClass", 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
                     Writer.Start_Element ("div");
                     if Style'Length > 0 then
                        Writer.Write_Attribute ("style", Style);
                     end if;
                     if Class'Length > 0 then
                        Writer.Write_Attribute ("class", Class);
                     end if;
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     Writer.End_Element ("div");
                     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);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SEND_ATTR'Access);

   TWITTER_ATTRIBUTE_NAMES.Insert (TW_SIZE_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_VIA_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_COUNTURL_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_TEXT_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_RELATED_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_LANG_ATTR'Access);
   TWITTER_ATTRIBUTE_NAMES.Insert (TW_HASHTAGS_ATTR'Access);
end ASF.Components.Widgets.Likes;

Remove Google+ like because they killed their service


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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

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

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

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

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.IO_Exceptions;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      begin
         loop
            exit when End_Of_File (Handle);
            Get (Handle, Char);
            if First then
               Put (File, "<![CDATA[");
               First := False;
            end if;
            CData_Ending := State_Change (CData_Ending);

            Put (File, Char);
            if End_Of_Line (Handle) then
               New_Line (File);
            end if;
         end loop;

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

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

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

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

Handle the End_Error exception which can be raised while reading a file