-----------------------------------------------------------------------
--  wiki-render-wiki -- Wiki to Wiki renderer
--  Copyright (C) 2015, 2016, 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.Strings.Wide_Wide_Maps;
with Ada.Strings.Wide_Wide_Unbounded;

with Wiki.Documents;
with Wiki.Attributes;
with Wiki.Streams;
with Wiki.Strings;

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

   use Standard.Wiki.Attributes;

   --  ------------------------------
   --  Wiki to HTML writer
   --  ------------------------------
   type Wiki_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine   : in out Wiki_Renderer;
                                Stream   : in Streams.Output_Stream_Access;
                                Format   : in Wiki_Syntax);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Wiki_Renderer;
                     Doc    : in Documents.Document;
                     Node   : in Nodes.Node_Type);

   --  Add a section header in the document.
   procedure Render_Header (Engine : in out Wiki_Renderer;
                            Header : in Wide_Wide_String;
                            Level  : in Positive);

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

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

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

   --  Render a link.
   procedure Render_Link (Engine : in out Wiki_Renderer;
                          Name     : in Strings.WString;
                          Attrs    : in Attributes.Attribute_List);

   --  Render an image.
   procedure Render_Image (Engine : in out Wiki_Renderer;
                           Link   : in Strings.WString;
                           Attrs  : in Attributes.Attribute_List);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Wiki_Renderer;
                           Title  : in Strings.WString;
                           Attrs  : in Attributes.Attribute_List);

   --  Add a text block with the given format.
   procedure Render_Text (Engine : in out Wiki_Renderer;
                          Text   : in Wide_Wide_String;
                          Format : in Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Wiki_Renderer;
                                  Text   : in Strings.WString;
                                  Format : in Strings.WString);

   procedure Render_Tag (Engine : in out Wiki_Renderer;
                         Doc    : in Documents.Document;
                         Node   : in Nodes.Node_Type);

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

   --  Set the text style format.
   procedure Set_Format (Engine : in out Wiki_Renderer;
                         Format   : in Format_Map);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   type Wide_String_Access is access constant Wide_Wide_String;

   type Wiki_Tag_Type is (Header_Start, Header_End,
                          Img_Start, Img_End,
                          Link_Start, Link_End, Link_Separator,
                          Quote_Start, Quote_End, Quote_Separator,
                          Preformat_Start, Preformat_End,
                          List_Start, List_Item, List_Ordered_Item,
                          Line_Break, Escape_Rule,
                          Horizontal_Rule,
                          Blockquote_Start, Blockquote_End);

   type Wiki_Tag_Array is array (Wiki_Tag_Type) of Wide_String_Access;

   type Wiki_Format_Array is array (Format_Type) of Wide_String_Access;

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

   procedure Close_Paragraph (Engine : in out Wiki_Renderer);
   procedure Open_Paragraph (Engine : in out Wiki_Renderer);
   procedure Start_Keep_Content (Engine : in out Wiki_Renderer);

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

   EMPTY_TAG : aliased constant Wide_Wide_String := "";

   type Wiki_Renderer is new Renderer with record
      Output              : Streams.Output_Stream_Access := null;
      Syntax              : Wiki_Syntax := SYNTAX_CREOLE;
      Format              : Format_Map := (others => False);
      Tags                : Wiki_Tag_Array := (others => EMPTY_TAG'Access);
      Style_Start_Tags    : Wiki_Format_Array := (others => EMPTY_TAG'Access);
      Style_End_Tags      : Wiki_Format_Array := (others => EMPTY_TAG'Access);
      Escape_Set          : Ada.Strings.Wide_Wide_Maps.Wide_Wide_Character_Set;
      Has_Paragraph       : Boolean := False;
      Has_Item            : Boolean := False;
      Need_Paragraph      : Boolean := False;
      Empty_Line          : Boolean := True;
      Keep_Content        : Boolean := False;
      In_List             : Boolean := False;
      Invert_Header_Level : Boolean := False;
      Allow_Link_Language : Boolean := False;
      Link_First          : Boolean := False;
      Html_Blockquote     : Boolean := False;
      Current_Level       : Natural := 0;
      Quote_Level         : Natural := 0;
      UL_List_Level       : Natural := 0;
      OL_List_Level       : Natural := 0;
      Current_Style       : Format_Map := (others => False);
      Content             : Unbounded_Wide_Wide_String;
      Link_Href           : Unbounded_Wide_Wide_String;
      Link_Title          : Unbounded_Wide_Wide_String;
      Link_Lang           : Unbounded_Wide_Wide_String;
   end record;

end Wiki.Render.Wiki;

-----------------------------------------------------------------------
--  wiki-render-wiki -- Wiki to Wiki renderer
--  Copyright (C) 2015, 2016, 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.Strings.Wide_Wide_Maps;
with Ada.Strings.Wide_Wide_Unbounded;

with Wiki.Documents;
with Wiki.Attributes;
with Wiki.Streams;
with Wiki.Strings;

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

   use Standard.Wiki.Attributes;

   --  ------------------------------
   --  Wiki to HTML writer
   --  ------------------------------
   type Wiki_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine   : in out Wiki_Renderer;
                                Stream   : in Streams.Output_Stream_Access;
                                Format   : in Wiki_Syntax);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Wiki_Renderer;
                     Doc    : in Documents.Document;
                     Node   : in Nodes.Node_Type);

   --  Add a section header in the document.
   procedure Render_Header (Engine : in out Wiki_Renderer;
                            Header : in Wide_Wide_String;
                            Level  : in Positive);

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

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

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

   --  Render a link.
   procedure Render_Link (Engine : in out Wiki_Renderer;
                          Name     : in Strings.WString;
                          Attrs    : in Attributes.Attribute_List);

   --  Render an image.
   procedure Render_Image (Engine : in out Wiki_Renderer;
                           Link   : in Strings.WString;
                           Attrs  : in Attributes.Attribute_List);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Wiki_Renderer;
                           Title  : in Strings.WString;
                           Attrs  : in Attributes.Attribute_List);

   --  Add a text block with the given format.
   procedure Render_Text (Engine : in out Wiki_Renderer;
                          Text   : in Wide_Wide_String;
                          Format : in Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Wiki_Renderer;
                                  Text   : in Strings.WString;
                                  Format : in Strings.WString);

   procedure Render_Tag (Engine : in out Wiki_Renderer;
                         Doc    : in Documents.Document;
                         Node   : in Nodes.Node_Type);

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

   --  Set the text style format.
   procedure Set_Format (Engine : in out Wiki_Renderer;
                         Format   : in Format_Map);

private

   use Ada.Strings.Wide_Wide_Unbounded;

   type Wide_String_Access is access constant Wide_Wide_String;

   type Wiki_Tag_Type is (Header_Start, Header_End,
                          Img_Start, Img_End,
                          Link_Start, Link_End, Link_Separator,
                          Quote_Start, Quote_End, Quote_Separator,
                          Preformat_Start, Preformat_End,
                          List_Start, List_Item, List_Ordered_Item,
                          Line_Break, Escape_Rule,
                          Horizontal_Rule,
                          Blockquote_Start, Blockquote_End);

   type Wiki_Tag_Array is array (Wiki_Tag_Type) of Wide_String_Access;

   type Wiki_Format_Array is array (Format_Type) of Wide_String_Access;

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

   procedure Close_Paragraph (Engine : in out Wiki_Renderer);
   procedure Open_Paragraph (Engine : in out Wiki_Renderer);
   procedure Start_Keep_Content (Engine : in out Wiki_Renderer);

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

   EMPTY_TAG : aliased constant Wide_Wide_String := "";

   type Wiki_Renderer is new Renderer with record
      Output              : Streams.Output_Stream_Access := null;
      Syntax              : Wiki_Syntax := SYNTAX_CREOLE;
      Format              : Format_Map := (others => False);
      Tags                : Wiki_Tag_Array := (others => EMPTY_TAG'Access);
      Style_Start_Tags    : Wiki_Format_Array := (others => EMPTY_TAG'Access);
      Style_End_Tags      : Wiki_Format_Array := (others => EMPTY_TAG'Access);
      Escape_Set          : Ada.Strings.Wide_Wide_Maps.Wide_Wide_Character_Set;
      Has_Paragraph       : Boolean := False;
      Has_Item            : Boolean := False;
      Need_Paragraph      : Boolean := False;
      Empty_Line          : Boolean := True;
      Keep_Content        : Boolean := False;
      In_List             : Boolean := False;
      Invert_Header_Level : Boolean := False;
      Allow_Link_Language : Boolean := False;
      Link_First          : Boolean := False;
      Html_Blockquote     : Boolean := False;
      Line_Count          : Natural := 0;
      Current_Level       : Natural := 0;
      Quote_Level         : Natural := 0;
      UL_List_Level       : Natural := 0;
      OL_List_Level       : Natural := 0;
      Current_Style       : Format_Map := (others => False);
      Content             : Unbounded_Wide_Wide_String;
      Link_Href           : Unbounded_Wide_Wide_String;
      Link_Title          : Unbounded_Wide_Wide_String;
      Link_Lang           : Unbounded_Wide_Wide_String;
   end record;

end Wiki.Render.Wiki;

Add Line_Count for the generator

Add Line_Count for the generator


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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Change the working directory before running dynamo.
   overriding
   procedure Set_Up (T : in out Test);

   --  Restore the working directory after running dynamo.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with serialization code.
   procedure Test_Generate_Zargo_Serialization (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Change the working directory before running dynamo.
   overriding
   procedure Set_Up (T : in out Test);

   --  Restore the working directory after running dynamo.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist with exclude support command.
   procedure Test_Dist_Exclude (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with serialization code.
   procedure Test_Generate_Zargo_Serialization (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

Declare the Test_Dist_Exclude procedure

Declare the Test_Dist_Exclude procedure


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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Change the working directory before running dynamo.
   overriding
   procedure Set_Up (T : in out Test);

   --  Restore the working directory after running dynamo.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Change the working directory before running dynamo.
   overriding
   procedure Set_Up (T : in out Test);

   --  Restore the working directory after running dynamo.
   overriding
   procedure Tear_Down (T : in out Test);

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with serialization code.
   procedure Test_Generate_Zargo_Serialization (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

Declare the Test_Generate_Zargo_Serialization procedure


-----------------------------------------------------------------------
--  awa-mail-module-tests -- Unit tests for Mail module
--  Copyright (C) 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 AWA.Events;

package body AWA.Mail.Modules.Tests is

   package Caller is new Util.Test_Caller (Test, "Mail.Clients");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Mail.Module.Create_Message",
                       Test_Create_Message'Access);
   end Add_Tests;

   --  Create an email message and verify its content.
   procedure Test_Create_Message (T : in out Test) is
      use Util.Beans.Objects;

      Mail  : constant AWA.Mail.Modules.Mail_Module_Access := AWA.Mail.Modules.Get_Mail_Module;
      Event : AWA.Events.Module_Event;
      Props : Util.Beans.Objects.Maps.Map;
   begin
      T.Assert (Mail /= null, "There is no current mail module");

      Props.Insert ("name", To_Object (String '("joe")));
      Props.Insert ("email", To_Object (String '("joe.rogers@somewhere.org")));
      Mail.Send_Mail (Template => "mail-info.html",
                      Props    => Props,
                      Content  => Event);

   end Test_Create_Message;

end AWA.Mail.Modules.Tests;

-----------------------------------------------------------------------
--  awa-mail-module-tests -- Unit tests for Mail module
--  Copyright (C) 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 Util.Test_Caller;

with AWA.Events;

package body AWA.Mail.Modules.Tests is

   package Caller is new Util.Test_Caller (Test, "Mail.Clients");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Mail.Module.Create_Message",
                       Test_Create_Message'Access);
      Caller.Add_Test (Suite, "Test AWA.Mail.Module.Create_Message (CC:)",
                       Test_Cc_Message'Access);
      Caller.Add_Test (Suite, "Test AWA.Mail.Module.Create_Message (BCC:)",
                       Test_Bcc_Message'Access);
   end Add_Tests;

   --  ------------------------------
   --  Create an email message with the given template and verify its content.
   --  ------------------------------
   procedure Test_Mail_Message (T    : in out Test;
                                Name : in String) is
      use Util.Beans.Objects;

      Mail  : constant AWA.Mail.Modules.Mail_Module_Access := AWA.Mail.Modules.Get_Mail_Module;
      Event : AWA.Events.Module_Event;
      Props : Util.Beans.Objects.Maps.Map;
   begin
      T.Assert (Mail /= null, "There is no current mail module");

      Props.Insert ("name", To_Object (String '("joe")));
      Props.Insert ("email", To_Object (String '("joe.rogers@somewhere.org")));
      Mail.Send_Mail (Template => Name,
                      Props    => Props,
                      Content  => Event);

   end Test_Mail_Message;

   --  ------------------------------
   --  Create an email message and verify its content.
   --  ------------------------------
   procedure Test_Create_Message (T : in out Test) is
   begin
      T.Test_Mail_Message ("mail-info.html");
   end Test_Create_Message;

   --  ------------------------------
   --  Create an email message with Cc: and verify its content.
   --  ------------------------------
   procedure Test_Cc_Message (T : in out Test) is
   begin
      T.Test_Mail_Message ("mail-cc.html");
   end Test_Cc_Message;

   --  ------------------------------
   --  Create an email message with Bcc: and verify its content.
   --  ------------------------------
   procedure Test_Bcc_Message (T : in out Test) is
   begin
      T.Test_Mail_Message ("mail-bcc.html");
   end Test_Bcc_Message;

end AWA.Mail.Modules.Tests;

Add new tests for mail Cc and Bcc

Add new tests for mail Cc and Bcc


-----------------------------------------------------------------------
--  awa-tags-components -- Tags component
--  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.Beans.Basic;
with Util.Beans.Objects;
with Util.Strings.Vectors;

with EL.Expressions;

with ASF.Components.Html.Forms;
with ASF.Contexts.Faces;
with ASF.Contexts.Writer;
with ASF.Events.Faces;
with ASF.Factory;

package AWA.Tags.Components is

   use ASF.Contexts.Writer;

   --  Get the Tags component factory.
   function Definition return ASF.Factory.Factory_Bindings_Access;

   --  ------------------------------
   --  Input component
   --  ------------------------------
   --  The AWA input component overrides the ASF input component to build a compact component
   --  that displays a label, the input field and the associated error message if necessary.
   --
   --  The generated HTML looks like:
   --
   --

   --
tag

   --

   --
   --  or
   --
   --    <input type='text' name='' value='tag'/>
   --
   type Tag_UIInput is new ASF.Components.Html.Forms.UIInput with record
      --  List of tags that have been added.
      Added    : Util.Strings.Vectors.Vector;

      --  List of tags that have been removed.
      Deleted  : Util.Strings.Vectors.Vector;

      --  True if the submitted values are correct.
      Is_Valid : Boolean := False;
   end record;
   type Tag_UIInput_Access is access all Tag_UIInput'Class;

   --  Returns True if the tag component must be rendered as readonly.
   function Is_Readonly (UI      : in Tag_UIInput;
                         Context : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean;

   --  Get the tag after convertion with the optional converter.
   function Get_Tag (UI      : in Tag_UIInput;
                     Tag     : in Util.Beans.Objects.Object;
                     Context : in ASF.Contexts.Faces.Faces_Context'Class) return String;

   --  Render the tag as a readonly item.
   procedure Render_Readonly_Tag (UI       : in Tag_UIInput;
                                  Tag      : in Util.Beans.Objects.Object;
                                  Class    : in Util.Beans.Objects.Object;
                                  Writer   : in Response_Writer_Access;
                                  Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the tag as a link.
   procedure Render_Link_Tag (UI       : in Tag_UIInput;
                              Name     : in String;
                              Tag      : in Util.Beans.Objects.Object;
                              Link     : in EL.Expressions.Expression;
                              Class    : in Util.Beans.Objects.Object;
                              Writer   : in Response_Writer_Access;
                              Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the tag for an input form.
   procedure Render_Form_Tag (UI       : in Tag_UIInput;
                              Id       : in String;
                              Tag      : in Util.Beans.Objects.Object;
                              Writer   : in Response_Writer_Access;
                              Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  a link is rendered for each tag.  Otherwise, each tag is rendered as a <tt>span</tt>.
   procedure Render_Readonly (UI      : in Tag_UIInput;
                              List    : in Util.Beans.Basic.List_Bean_Access;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the list of tags for a form.
   procedure Render_Form (UI      : in Tag_UIInput;
                          List    : in Util.Beans.Basic.List_Bean_Access;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the javascript to enable the tag edition.
   procedure Render_Script (UI      : in Tag_UIInput;
                            Id      : in String;
                            Writer  : in Response_Writer_Access;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the input component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   overriding
   procedure Encode_Begin (UI      : in Tag_UIInput;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the end of the input component.  Closes the DL/DD list.
   overriding
   procedure Encode_End (UI      : in Tag_UIInput;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Get the action method expression to invoke if the command is pressed.
   --  ------------------------------
   function Get_Action_Expression (UI      : in Tag_UIInput;
                                   Context : in ASF.Contexts.Faces.Faces_Context'Class)
                                   return EL.Expressions.Method_Expression;

   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   overriding
   procedure Process_Decodes (UI      : in out Tag_UIInput;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   overriding
   procedure Process_Updates (UI      : in out Tag_UIInput;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Broadcast the event to the event listeners installed on this component.
   --  Listeners are called in the order in which they were added.
   overriding
   procedure Broadcast (UI      : in out Tag_UIInput;
                        Event   : not null access ASF.Events.Faces.Faces_Event'Class;
                        Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end AWA.Tags.Components;

-----------------------------------------------------------------------
--  awa-tags-components -- Tags component
--  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.Beans.Basic;
with Util.Beans.Objects;
with Util.Strings.Vectors;

with EL.Expressions;

with ASF.Components.Html.Forms;
with ASF.Contexts.Faces;
with ASF.Contexts.Writer;
with ASF.Events.Faces;
with ASF.Factory;

--  == Tags Component ==
--
--  === Displaying a list of tags ===
--  The <tt>awa:tagList</tt> component displays a list of tags.  Each tag can be rendered as
--  a link if the <tt>tagLink</tt> attribute is defined.  The list of tags is passed in the
--  <tt>value</tt> attribute.  When rending that list, the <tt>var</tt> attribute is used to
--  setup a variable with the tag value.  The <tt>tagLink</tt> attribute is then evaluated
--  against that variable and the result defines the link.
--
--    <awa:tagList value='#{questionList.tags}' id='qtags' styleClass="tagedit-list"
--                 tagLink="#{contextPath}/questions/tagged.html?tag=#{tagName}"
--                 var="tagName"
--                 tagClass="tagedit-listelement tagedit-listelement-old"/>
--
--  === Tag editing ===
--  The <tt>awa:tagList</tt> component allows to add or remove tags associated with a given
--  database entity.  The tag management works with the jQuery plugin Tagedit.  For this,
--  the page must include the /js/jquery.tagedit.js Javascript resource.
--
--  The tag edition is active only if the <tt>awa:tagList</tt> component is placed within an
--  <tt>h:form</tt> component.  The <tt>value</tt> attribute defines the list of tags.  This must
--  be a <tt>Tag_List_Bean</tt> object.
--
--    <awa:tagList value='#{question.tags}' id='qtags'
--                 autoCompleteUrl='#{contextPath}/questions/lists/tag-search.html'/>
--
--  When the form is submitted and validated, the procedure <tt>Set_Added</tt> and
--  <tt>Set_Deleted</tt> are called on the value bean with the list of tags that were
--  added and removed.  These operations are called in the <tt>UPDATE_MODEL_VALUES</tt>
--  phase (ie, before calling the action's bean operation).
--
package AWA.Tags.Components is

   use ASF.Contexts.Writer;

   --  Get the Tags component factory.
   function Definition return ASF.Factory.Factory_Bindings_Access;

   --  ------------------------------
   --  Input component
   --  ------------------------------
   --  The AWA input component overrides the ASF input component to build a compact component
   --  that displays a label, the input field and the associated error message if necessary.
   --
   --  The generated HTML looks like:
   --
   --

   --
tag

   --

   --
   --  or
   --
   --    <input type='text' name='' value='tag'/>
   --
   type Tag_UIInput is new ASF.Components.Html.Forms.UIInput with record
      --  List of tags that have been added.
      Added    : Util.Strings.Vectors.Vector;

      --  List of tags that have been removed.
      Deleted  : Util.Strings.Vectors.Vector;

      --  True if the submitted values are correct.
      Is_Valid : Boolean := False;
   end record;
   type Tag_UIInput_Access is access all Tag_UIInput'Class;

   --  Returns True if the tag component must be rendered as readonly.
   function Is_Readonly (UI      : in Tag_UIInput;
                         Context : in ASF.Contexts.Faces.Faces_Context'Class) return Boolean;

   --  Get the tag after convertion with the optional converter.
   function Get_Tag (UI      : in Tag_UIInput;
                     Tag     : in Util.Beans.Objects.Object;
                     Context : in ASF.Contexts.Faces.Faces_Context'Class) return String;

   --  Render the tag as a readonly item.
   procedure Render_Readonly_Tag (UI       : in Tag_UIInput;
                                  Tag      : in Util.Beans.Objects.Object;
                                  Class    : in Util.Beans.Objects.Object;
                                  Writer   : in Response_Writer_Access;
                                  Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the tag as a link.
   procedure Render_Link_Tag (UI       : in Tag_UIInput;
                              Name     : in String;
                              Tag      : in Util.Beans.Objects.Object;
                              Link     : in EL.Expressions.Expression;
                              Class    : in Util.Beans.Objects.Object;
                              Writer   : in Response_Writer_Access;
                              Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the tag for an input form.
   procedure Render_Form_Tag (UI       : in Tag_UIInput;
                              Id       : in String;
                              Tag      : in Util.Beans.Objects.Object;
                              Writer   : in Response_Writer_Access;
                              Context  : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  a link is rendered for each tag.  Otherwise, each tag is rendered as a <tt>span</tt>.
   procedure Render_Readonly (UI      : in Tag_UIInput;
                              List    : in Util.Beans.Basic.List_Bean_Access;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the list of tags for a form.
   procedure Render_Form (UI      : in Tag_UIInput;
                          List    : in Util.Beans.Basic.List_Bean_Access;
                          Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the javascript to enable the tag edition.
   procedure Render_Script (UI      : in Tag_UIInput;
                            Id      : in String;
                            Writer  : in Response_Writer_Access;
                            Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the input component.  Starts the DL/DD list and write the input
   --  component with the possible associated error message.
   overriding
   procedure Encode_Begin (UI      : in Tag_UIInput;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Render the end of the input component.  Closes the DL/DD list.
   overriding
   procedure Encode_End (UI      : in Tag_UIInput;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Get the action method expression to invoke if the command is pressed.
   function Get_Action_Expression (UI      : in Tag_UIInput;
                                   Context : in ASF.Contexts.Faces.Faces_Context'Class)
                                   return EL.Expressions.Method_Expression;

   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   overriding
   procedure Process_Decodes (UI      : in out Tag_UIInput;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   overriding
   procedure Process_Updates (UI      : in out Tag_UIInput;
                              Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Broadcast the event to the event listeners installed on this component.
   --  Listeners are called in the order in which they were added.
   overriding
   procedure Broadcast (UI      : in out Tag_UIInput;
                        Event   : not null access ASF.Events.Faces.Faces_Event'Class;
                        Context : in out ASF.Contexts.Faces.Faces_Context'Class);

end AWA.Tags.Components;

Document how to use the <awa:tagList> component


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

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Files;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with ADO;

with EL.Contexts.TLS;

with Servlet.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with AWA.Applications;
with AWA.Services.Contexts;
with AWA.Modules.Get;
package body AWA.Wikis.Previews is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Preview");

   --  ------------------------------
   --  The worker procedure that performs the preview job.
   --  ------------------------------
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Previewer : constant Preview_Module_Access := Get_Preview_Module;
   begin
      Previewer.Do_Preview_Job (Job);
   end Preview_Worker;

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

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

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Preview_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Template := Plugin.Get_Config (PARAM_PREVIEW_TEMPLATE);
      Plugin.Command := Plugin.Get_Config (PARAM_PREVIEW_COMMAND);
      Plugin.Html := Plugin.Get_Config (PARAM_PREVIEW_HTML);
      Plugin.Add_Listener (AWA.Wikis.Modules.NAME, Plugin'Unchecked_Access);
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      Plugin.Job_Module.Register (Definition => Preview_Job_Definition.Factory);
   end Configure;

   --  ------------------------------
   --  Execute the preview job and make the thumbnail preview.  The page is first rendered in
   --  an HTML text file and the preview is rendered by using an external command.
   --  ------------------------------
   procedure Do_Preview_Job (Plugin : in Preview_Module;
                             Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      pragma Unreferenced (Job);
      use Util.Beans.Objects;

      Ctx       : constant EL.Contexts.ELContext_Access := EL.Contexts.TLS.Current;
      Template  : constant String := To_String (Plugin.Template.Get_Value (Ctx.all));
      Command   : constant String := To_String (Plugin.Command.Get_Value (Ctx.all));
      Html_File : constant String := To_String (Plugin.Html.Get_Value (Ctx.all));
   begin
      Log.Info ("Preview {0} with {1}", Template, Command);
      declare
         Req       : ASF.Requests.Mockup.Request;
         Reply     : ASF.Responses.Mockup.Response;
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := Plugin.Get_Application.Get_Request_Dispatcher (Template);
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");

         Servlet.Core.Forward (Dispatcher, Req, Reply);
         Reply.Read_Content (Result);
         Util.Files.Write_File (Html_File, Result);
      end;

      declare
         Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Log.Info ("Running preview command {0}", Command);

         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
            begin
               Input.Read_Line (Line, False);
               Log.Info ("Received: {0}", Line);
            end;
         end loop;
         Pipe.Close;
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Do_Preview_Job;

   --  ------------------------------
   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   --  ------------------------------
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("wiki_space_id", Page.Get_Wiki);
      J.Set_Parameter ("wiki_page_id", Page);
      J.Schedule (Preview_Job_Definition.Factory.all);
   end Make_Preview_Job;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      null;
   end On_Delete;

   --  ------------------------------
   --  Get the preview module instance associated with the current application.
   --  ------------------------------
   function Get_Preview_Module return Preview_Module_Access is
      function Get is new AWA.Modules.Get (Preview_Module, Preview_Module_Access, NAME);
   begin
      return Get;
   end Get_Preview_Module;

end AWA.Wikis.Previews;

-----------------------------------------------------------------------
--  awa-wikis-previews -- Wiki preview management
--  Copyright (C) 2015, 2018, 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.Strings.Unbounded;

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Files;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Texts;

with EL.Contexts.TLS;

with Servlet.Core;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;

with AWA.Applications;
with AWA.Services.Contexts;
with AWA.Modules.Get;
package body AWA.Wikis.Previews is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Wikis.Preview");

   --  ------------------------------
   --  The worker procedure that performs the preview job.
   --  ------------------------------
   procedure Preview_Worker (Job : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      Previewer : constant Preview_Module_Access := Get_Preview_Module;
   begin
      Previewer.Do_Preview_Job (Job);
   end Preview_Worker;

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

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

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out Preview_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Template := Plugin.Get_Config (PARAM_PREVIEW_TEMPLATE);
      Plugin.Command := Plugin.Get_Config (PARAM_PREVIEW_COMMAND);
      Plugin.Html := Plugin.Get_Config (PARAM_PREVIEW_HTML);
      Plugin.Add_Listener (AWA.Wikis.Modules.NAME, Plugin'Unchecked_Access);
      Plugin.Job_Module := AWA.Jobs.Modules.Get_Job_Module;
      Plugin.Job_Module.Register (Definition => Preview_Job_Definition.Factory);
   end Configure;

   --  ------------------------------
   --  Execute the preview job and make the thumbnail preview.  The page is first rendered in
   --  an HTML text file and the preview is rendered by using an external command.
   --  ------------------------------
   procedure Do_Preview_Job (Plugin : in Preview_Module;
                             Job    : in out AWA.Jobs.Services.Abstract_Job_Type'Class) is
      pragma Unreferenced (Job);
      use Util.Beans.Objects;

      Ctx       : constant EL.Contexts.ELContext_Access := EL.Contexts.TLS.Current;
      Template  : constant String := To_String (Plugin.Template.Get_Value (Ctx.all));
      Command   : constant String := To_String (Plugin.Command.Get_Value (Ctx.all));
      Html_File : constant String := To_String (Plugin.Html.Get_Value (Ctx.all));
   begin
      Log.Info ("Preview {0} with {1}", Template, Command);
      declare
         Req       : ASF.Requests.Mockup.Request;
         Reply     : ASF.Responses.Mockup.Response;
         Dispatcher : constant Servlet.Core.Request_Dispatcher
           := Plugin.Get_Application.Get_Request_Dispatcher (Template);
         Result : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Req.Set_Request_URI (Template);
         Req.Set_Method ("GET");

         Servlet.Core.Forward (Dispatcher, Req, Reply);
         Reply.Read_Content (Result);
         Util.Files.Write_File (Html_File, Result);
      end;

      declare
         Pipe    : aliased Util.Streams.Pipes.Pipe_Stream;
         Input   : Util.Streams.Texts.Reader_Stream;
      begin
         Log.Info ("Running preview command {0}", Command);

         Pipe.Open (Command, Util.Processes.READ_ALL);
         Input.Initialize (Pipe'Unchecked_Access, 1024);
         while not Input.Is_Eof loop
            declare
               Line : Ada.Strings.Unbounded.Unbounded_String;
            begin
               Input.Read_Line (Line, False);
               Log.Info ("Received: {0}", Line);
            end;
         end loop;
         Pipe.Close;
         if Pipe.Get_Exit_Status /= 0 then
            Log.Error ("Command {0} exited with status {1}", Command,
                       Integer'Image (Pipe.Get_Exit_Status));
         end if;
      end;
   end Do_Preview_Job;

   --  ------------------------------
   --  Create a preview job and schedule the job to generate a new thumbnail preview for the page.
   --  ------------------------------
   procedure Make_Preview_Job (Plugin : in Preview_Module;
                               Page   : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
      pragma Unreferenced (Plugin);

      J : AWA.Jobs.Services.Job_Type;
   begin
      J.Set_Parameter ("wiki_space_id", Page.Get_Wiki);
      J.Set_Parameter ("wiki_page_id", Page);
      J.Schedule (Preview_Job_Definition.Factory.all);
   end Make_Preview_Job;

   --  ------------------------------
   --  The `On_Create` procedure is called by `Notify_Create` to notify the creation of the page.
   --  ------------------------------
   overriding
   procedure On_Create (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Create;

   --  ------------------------------
   --  The `On_Update` procedure is called by `Notify_Update` to notify the update of the page.
   --  ------------------------------
   overriding
   procedure On_Update (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      Instance.Make_Preview_Job (Item);
   end On_Update;

   --  ------------------------------
   --  The `On_Delete` procedure is called by `Notify_Delete` to notify the deletion of the page.
   --  ------------------------------
   overriding
   procedure On_Delete (Instance : in Preview_Module;
                        Item     : in AWA.Wikis.Models.Wiki_Page_Ref'Class) is
   begin
      null;
   end On_Delete;

   --  ------------------------------
   --  Get the preview module instance associated with the current application.
   --  ------------------------------
   function Get_Preview_Module return Preview_Module_Access is
      function Get is new AWA.Modules.Get (Preview_Module, Preview_Module_Access, NAME);
   begin
      return Get;
   end Get_Preview_Module;

end AWA.Wikis.Previews;

Remove unused with clause

Remove unused with clause


-- ------------------------------------------------
--  Paquet de declaracions de la taula de noms
-- ------------------------------------------------
--  Versió			:	0.1
--  Autors			:	José Ruiz Bravo
--						Biel Moyà Alcover
--						Álvaro Medina Ballester
-- ------------------------------------------------
--		Aquí una petita descripció.
--
-- ------------------------------------------------

with decls.dgenerals;
use decls.dgenerals;
with Ada.Text_IO;
use Ada.Text_IO;

package decls.d_taula_de_noms is

	--pragma(pure);

	type taula_de_noms is  private;

	procedure tbuida(tn : out taula_de_noms);
	procedure posa(tn : in out taula_de_noms;  idn : out id_nom ; nom : in string);
	procedure imprimir_tcar(tn : in taula_de_noms; nparaules : integer);
	--function cons(tn : in taula_de_noms; idn : in id_nom ) return string;
	--procedure posa(tn : in out taula_de_noms; s : in string; ids : out string);
	--function cons(tn : in taula_de_noms; ids : in  string) return string;

	private

		longitut :constant integer := 40;
		num_dispersio : constant integer := 255;

		type rang_dispersio is new integer range -1..num_dispersio;
		type rang_tcaracters is  new integer range 0..(longitut*max_id)-1 ;--longitut d'una paraula * nombre paraules

		dispersio_nul :  rang_dispersio := -1;

		type t_identificador is record
			pos_tcaracters: rang_tcaracters;
			seguent : id_nom;
			long_paraula : Natural;--aixo es logic, a mes es un apao, ja que al recorrer, el string es molt mes senzill!

		end record;

		type taula_dispersio is array (rang_dispersio) of  id_nom;
		type taula_identificadors is array (id_nom) of t_identificador  ;
		type taula_caracters is array (rang_tcaracters) of character ;

		type taula_de_noms is record
				td : taula_dispersio;
				tid : taula_identificadors;
				tc : taula_caracters;
				nid :  id_nom;
				ncar : rang_tcaracters;
		end record;

		function fdisp (nom: in string) return rang_dispersio;

end decls.d_taula_de_noms;

Prueba con 2 palabras

Prueba con 2 palabras

git-svn-id: 21e5e84ea84925cd81557fe364e06047ebebbce6@6 92701e50-6359-0410-9b06-881c3d199c04


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

with Util.Test_Caller;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Storages.Modules;
with AWA.Storages.Beans.Factories;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Create_Image",
                       Test_Create_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String := Util.Tests.Get_Test_Path ("bast-12-thumb.jpg");
      Width     : Natural;
      Height    : Natural;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Manager;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
   end Test_Create_Image;

end AWA.Images.Services.Tests;

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

with Util.Test_Caller;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Storages.Modules;
with AWA.Storages.Beans.Factories;
with AWA.Tests.Helpers.Users;
with AWA.Images.Modules;
package body AWA.Images.Services.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Images.Create_Image",
                       Test_Create_Image'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a storage object
   --  ------------------------------
   procedure Test_Create_Image (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Source    : constant String := Util.Tests.Get_Path ("regtests/files/images/bast-12.jpg");
      Thumb     : constant String := Util.Tests.Get_Test_Path ("regtests/result/bast-12-thumb.jpg");
      Width     : Natural;
      Height    : Natural;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");
      T.Manager := AWA.Images.Modules.Get_Image_Manager;

      T.Manager.Create_Thumbnail (Source, Thumb, Width, Height);
      Util.Tests.Assert_Equals (T, 1720, Width, "Invalid image width");
      Util.Tests.Assert_Equals (T, 1098, Height, "Invalid image height");
   end Test_Create_Image;

end AWA.Images.Services.Tests;

Check the image width and height for the unit test.


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

package body Security.Controllers.Roles is

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

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         for I in Handler.Roles'Range loop
--              if P.Has_Role (Handler.Roles (I)) then
               return True;
--              end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

end Security.Controllers.Roles;

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

package body Security.Controllers.Roles is

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

      use type Security.Principal_Access;

      P     : constant Security.Principal_Access := Context.Get_User_Principal;
      Roles : Security.Policies.Roles.Role_Map;
   begin
      if P /= null then
         --  If the principal has some roles, get them.
         if P.all in Policies.Roles.Role_Principal_Context'Class then
            Roles := Policies.Roles.Role_Principal_Context'Class (P.all).Get_Roles;
         else
            return False;
         end if;

         for I in Handler.Roles'Range loop
            if Roles (Handler.Roles (I)) then
               return True;
            end if;
         end loop;
      end if;
      return False;
   end Has_Permission;

end Security.Controllers.Roles;

Check if the principal implements the Role_Principal_Context interface and get the user's roles with it


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

with Security.Permissions;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

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

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

   function To_String (OP : End_Point) return String;

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

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

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

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

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

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

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

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

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

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

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

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

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

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

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

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

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

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

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

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The process is the following:
   --
   --  o Initialize is called to configure the OpenID realm and set the
   --    OpenID return callback CB.
   --  o Discover is called to retrieve from the OpenID provider the XRDS
   --    stream and identify the provider.  An End_Point is returned.
   --  o Associate is called to make the association with the End_Point.
   --    The Association record holds session, and authentication.
   --  o Get_Authentication_URL builds the provider OpenID authentication
   --    URL for the association.
   --  o The user should be redirected to the authentication URL.
   --  o The OpenID provider authenticate the user and redirects the user to the callback CB.
   --  o The association is decoded from the callback parameter.
   --  o Verify is called with the association to check the result and
   --    obtain the authentication results.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

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

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

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

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

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

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

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

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

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

end Security.Openid;

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

with Security.Permissions;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  === Authentication process ==
--  The process is the following:
--
--    * The Initialize procedure is called to configure the OpenID realm and set the
--      OpenID return callback CB.
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--    * The Get_Authentication_URL builds the provider OpenID authentication
--      URL for the association.
--    * The application should redirected the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

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

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

   function To_String (OP : End_Point) return String;

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

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

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

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

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

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

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

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

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

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

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

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

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

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

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

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

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

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

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

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

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

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

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

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

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

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

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

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

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

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

end Security.Openid;

Document the OpenID process

Document the OpenID process