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

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

end MAT.Expressions;

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

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

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Node_Type,
                                     Name   => Node_Type_Access);

   --  Destroy recursively the node, releasing the storage.
   procedure Destroy (Node : in out Node_Type_Access);

   --  ------------------------------
   --  Create a NOT expression node.
   --  ------------------------------
   function Create_Not (Expr : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_NOT,
                                    Expr        => Expr.Node);
      Util.Concurrent.Counters.Increment (Expr.Node.Ref_Counter);
      return Result;
   end Create_Not;

   --  ------------------------------
   --  Create a AND expression node.
   --  ------------------------------
   function Create_And (Left  : in Expression_Type;
                        Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_AND,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_And;

   --  ------------------------------
   --  Create a OR expression node.
   --  ------------------------------
   function Create_Or (Left  : in Expression_Type;
                       Right : in Expression_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_OR,
                                    Left        => Left.Node,
                                    Right       => Right.Node);
      Util.Concurrent.Counters.Increment (Left.Node.Ref_Counter);
      Util.Concurrent.Counters.Increment (Right.Node.Ref_Counter);
      return Result;
   end Create_Or;

   --  ------------------------------
   --  Create an INSIDE expression node.
   --  ------------------------------
   function Create_Inside (Name : in Ada.Strings.Unbounded.Unbounded_String;
                           Kind : in Inside_Type) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_INSIDE,
                                    Name        => Name,
                                    Inside      => Kind);
      return Result;
   end Create_Inside;

   --  ------------------------------
   --  Create an size range expression node.
   --  ------------------------------
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_SIZE,
                                    Min_Size    => Min,
                                    Max_Size    => Max);
      return Result;
   end Create_Size;

   --  ------------------------------
   --  Create an addr range expression node.
   --  ------------------------------
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_ADDR,
                                    Min_Addr    => Min,
                                    Max_Addr    => Max);
      return Result;
   end Create_Addr;

   --  ------------------------------
   --  Create an time range expression node.
   --  ------------------------------
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type is
      Result : Expression_Type;
   begin
      Result.Node := new Node_Type'(Ref_Counter => Util.Concurrent.Counters.ONE,
                                    Kind        => N_RANGE_TIME,
                                    Min_Time    => Min,
                                    Max_Time    => Max);
      return Result;
   end Create_Time;

   --  ------------------------------
   --  Evaluate the expression to check if the memory slot described by the
   --  context is selected.  Returns True if the memory slot is selected.
   --  ------------------------------
   function Is_Selected (Node       : in Expression_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
   begin
      if Node.Node = null then
         return True;
      else
         return Is_Selected (Node.Node.all, Addr, Allocation);
      end if;
   end Is_Selected;

   --  ------------------------------
   --  Evaluate the node against the context.  Returns True if the node expression
   --  selects the memory slot defined by the context.
   --  ------------------------------
   function Is_Selected (Node       : in Node_Type;
                         Addr       : in MAT.Types.Target_Addr;
                         Allocation : in MAT.Memory.Allocation) return Boolean is
      use type MAT.Types.Target_Size;
      use type MAT.Types.Target_Tick_Ref;
   begin
      case Node.Kind is
         when N_NOT =>
            return not Is_Selected (Node.Expr.all, Addr, Allocation);

         when N_AND =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              and then Is_Selected (Node.Right.all, Addr, Allocation);

         when N_OR =>
            return Is_Selected (Node.Left.all, Addr, Allocation)
              or else Is_Selected (Node.Right.all, Addr, Allocation);

         when N_RANGE_SIZE =>
            return Allocation.Size >= Node.Min_Size
              and Allocation.Size <= Node.Max_Size;

         when N_RANGE_ADDR =>
            return Addr >= Node.Min_Addr
              and Addr <= Node.Max_Addr;

         when N_RANGE_TIME =>
            return Allocation.Time >= Node.Min_Time
              and Allocation.Time <= Node.Max_Time;

         when others =>
            return False;

      end case;
   end Is_Selected;

   --  ------------------------------
   --  Parse the string and return the expression tree.
   --  ------------------------------
   function Parse (Expr : in String) return Expression_Type is
   begin
      return MAT.Expressions.Parser.Parse (Expr);
   end Parse;

   --  ------------------------------
   --  Destroy recursively the node, releasing the storage.
   --  ------------------------------
   procedure Destroy (Node : in out Node_Type_Access) is
      Release : Boolean;
   begin
      if Node /= null then
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Release);
         case Node.Kind is
            when N_NOT =>
               Destroy (Node.Expr);

            when N_AND | N_OR =>
               Destroy (Node.Left);
               Destroy (Node.Right);

            when others =>
               null;
         end case;
         if Release then
            Free (Node);
         else
            Node := null;
         end if;
      end if;
   end Destroy;

   --  ------------------------------
   --  Release the reference and destroy the expression tree if it was the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Destroy (Obj.Node);
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Expression_Type) is
   begin
      if Obj.Node /= null then
         Util.Concurrent.Counters.Increment (Obj.Node.Ref_Counter);
      end if;
   end Adjust;

end MAT.Expressions;

Implement the Adjust procedure

Implement the Adjust procedure


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

private with Util.Concurrent.Counters;

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

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

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

   type Inside_Type is (INSIDE_FILE, INSIDE_FUNCTION);

   type Expression_Type is tagged private;

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

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

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

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

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

private

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

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

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

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

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

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

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

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

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

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

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

end MAT.Expressions;

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

private with Util.Concurrent.Counters;

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

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

   type Inside_Type is (INSIDE_FILE, INSIDE_FUNCTION);

   type Expression_Type is tagged private;

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

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

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

   --  Create an INSIDE expression node.
   function Create_Inside (Name : in String;
                           Kind : in Inside_Type) return Expression_Type;

   --  Create an size range expression node.
   function Create_Size (Min : in MAT.Types.Target_Size;
                         Max : in MAT.Types.Target_Size) return Expression_Type;

   --  Create an addr range expression node.
   function Create_Addr (Min : in MAT.Types.Target_Addr;
                         Max : in MAT.Types.Target_Addr) return Expression_Type;

   --  Create an time range expression node.
   function Create_Time (Min : in MAT.Types.Target_Tick_Ref;
                         Max : in MAT.Types.Target_Tick_Ref) return Expression_Type;

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

private

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

   type Node_Type;
   type Node_Type_Access is access all Node_Type;

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

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

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

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

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

         when N_RANGE_TIME =>
            Min_Time : MAT.Types.Target_Tick_Ref;
            Max_Time : MAT.Types.Target_Tick_Ref;

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

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

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

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

end MAT.Expressions;

Make the Kind_Type private

Make the Kind_Type private


-----------------------------------------------------------------------
--  wiki-attributes -- Wiki document attributes
--  Copyright (C) 2015, 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.Wide_Wide_Unbounded;
private with Ada.Containers.Vectors;
private with Ada.Finalization;
private with Util.Refs;

--  == Attributes ==
--  The  <tt>Attributes</tt> package defines a simple management of attributes for
--  the wiki document parser.  Attribute lists are described by the <tt>Attribute_List_Type</tt>
--  with some operations to append or query for an attribute.
package Wiki.Attributes is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Cursor is private;

   --  Get the attribute name.
   function Get_Name (Position : in Cursor) return String;

   --  Get the attribute value.
   function Get_Value (Position : in Cursor) return String;

   --  Get the attribute wide value.
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String;

   --  Get the attribute wide value.
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String;

   --  Returns True if the cursor has a valid attribute.
   function Has_Element (Position : in Cursor) return Boolean;

   --  Move the cursor to the next attribute.
   procedure Next (Position : in out Cursor);

   --  A list of attributes.
   type Attribute_List_Type is private;

   --  Find the attribute with the given name.
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String;

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Get the cursor to get access to the first attribute.
   function First (List : in Attribute_List_Type) return Cursor;

   --  Get the number of attributes in the list.
   function Length (List : in Attribute_List_Type) return Natural;

   --  Clear the list and remove all existing attributes.
   procedure Clear (List : in out Attribute_List_Type);

   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String));

private

   type Attribute (Name_Length, Value_Length : Natural) is limited
   new Util.Refs.Ref_Entity with record
      Name   : String (1 .. Name_Length);
      Value  : Wide_Wide_String (1 .. Value_Length);
   end record;
   type Attribute_Access is access all Attribute;

   package Attribute_Refs is new Util.Refs.Indefinite_References (Attribute, Attribute_Access);

   use Attribute_Refs;

   subtype Attribute_Ref is Attribute_Refs.Ref;

   package Attribute_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Attribute_Ref);

   subtype Attribute_Vector is Attribute_Vectors.Vector;

   type Cursor is record
      Pos : Attribute_Vectors.Cursor;
   end record;

   type Attribute_List_Type is new Ada.Finalization.Controlled with record
      List    : Attribute_Vector;
   end record;

   --  Finalize the attribute list releasing any storage.
   overriding
   procedure Finalize (List : in out Attribute_List_Type);

end Wiki.Attributes;

-----------------------------------------------------------------------
--  wiki-attributes -- Wiki document attributes
--  Copyright (C) 2015, 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.Wide_Wide_Unbounded;
private with Ada.Containers.Vectors;
private with Ada.Finalization;
private with Util.Refs;

--  == Attributes ==
--  The  <tt>Attributes</tt> package defines a simple management of attributes for
--  the wiki document parser.  Attribute lists are described by the <tt>Attribute_List_Type</tt>
--  with some operations to append or query for an attribute.
package Wiki.Attributes is

   pragma Preelaborate;

   use Ada.Strings.Wide_Wide_Unbounded;

   type Cursor is private;

   --  Get the attribute name.
   function Get_Name (Position : in Cursor) return String;

   --  Get the attribute value.
   function Get_Value (Position : in Cursor) return String;

   --  Get the attribute wide value.
   function Get_Wide_Value (Position : in Cursor) return Wide_Wide_String;

   --  Get the attribute wide value.
   function Get_Unbounded_Wide_Value (Position : in Cursor) return Unbounded_Wide_Wide_String;

   --  Returns True if the cursor has a valid attribute.
   function Has_Element (Position : in Cursor) return Boolean;

   --  Move the cursor to the next attribute.
   procedure Next (Position : in out Cursor);

   --  A list of attributes.
   type Attribute_List_Type is private;

   --  Find the attribute with the given name.
   function Find (List : in Attribute_List_Type;
                  Name : in String) return Cursor;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Unbounded_Wide_Wide_String;

   --  Find the attribute with the given name and return its value.
   function Get_Attribute (List : in Attribute_List_Type;
                           Name : in String) return Wide_Wide_String;

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Wide_Wide_String;
                     Value : in Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Append the attribute to the attribute list.
   procedure Append (List  : in out Attribute_List_Type;
                     Name  : in String;
                     Value : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Get the cursor to get access to the first attribute.
   function First (List : in Attribute_List_Type) return Cursor;

   --  Get the number of attributes in the list.
   function Length (List : in Attribute_List_Type) return Natural;

   --  Clear the list and remove all existing attributes.
   procedure Clear (List : in out Attribute_List_Type);

   --  Iterate over the list attributes and call the <tt>Process</tt> procedure.
   procedure Iterate (List    : in Attribute_List_Type;
                      Process : not null access procedure (Name : in String;
                                                           Value : in Wide_Wide_String));

private

   type Attribute (Name_Length, Value_Length : Natural) is limited
   new Util.Refs.Ref_Entity with record
      Name   : String (1 .. Name_Length);
      Value  : Wide_Wide_String (1 .. Value_Length);
   end record;
   type Attribute_Access is access all Attribute;

   package Attribute_Refs is new Util.Refs.Indefinite_References (Attribute, Attribute_Access);

   use Attribute_Refs;

   subtype Attribute_Ref is Attribute_Refs.Ref;

   package Attribute_Vectors is
     new Ada.Containers.Vectors (Index_Type   => Positive,
                                 Element_Type => Attribute_Ref);

   subtype Attribute_Vector is Attribute_Vectors.Vector;

   type Cursor is record
      Pos : Attribute_Vectors.Cursor;
   end record;

   type Attribute_List_Type is new Ada.Finalization.Controlled with record
      List    : Attribute_Vector;
   end record;

   --  Finalize the attribute list releasing any storage.
   overriding
   procedure Finalize (List : in out Attribute_List_Type);

end Wiki.Attributes;

Declare Get_Attribute function returning a Wide_Wide_String


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

with Util.Test_Caller;

with Wiki.Utils;
package body Wiki.Parsers.Tests is

   package Caller is new Util.Test_Caller (Test, "Wikis.Parsers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (bold)",
                       Test_Wiki_Bold'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (italic)",
                       Test_Wiki_Italic'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (italic, bold)",
                       Test_Wiki_Formats'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (headings)",
                       Test_Wiki_Section'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (lists)",
                       Test_Wiki_List'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (links)",
                       Test_Wiki_Link'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (quote)",
                       Test_Wiki_Quote'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (line break)",
                       Test_Wiki_Line_Break'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (image)",
                       Test_Wiki_Image'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (preformatted)",
                       Test_Wiki_Preformatted'Access);
      Caller.Add_Test (Suite, "Test Wiki.Text.Renderer",
                       Test_Wiki_Text_Renderer'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test bold rendering.
   --  ------------------------------
   procedure Test_Wiki_Bold (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
bold
",
                                Wiki.Utils.To_Html ("*bold*", SYNTAX_GOOGLE),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x *bold* y", SYNTAX_GOOGLE),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x *bold y", SYNTAX_MIX),
                                "Bold rendering invalid (MIX)");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x __item y__ p", SYNTAX_DOTCLEAR),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x _item y_ p
",
                                Wiki.Utils.To_Html ("x _item y_ p", SYNTAX_DOTCLEAR),
                                "No bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x '''bold''' y", SYNTAX_PHPBB),
                                "Bold rendering invalid (PHPBB)");
   end Test_Wiki_Bold;

   --  ------------------------------
   --  Test italic rendering.
   --  ------------------------------
   procedure Test_Wiki_Italic (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("_item_", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item_ y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item y", SYNTAX_MIX),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x ''item y'' p", SYNTAX_DOTCLEAR),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x ''item y'' p", SYNTAX_PHPBB),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x 'item y p
",
                                Wiki.Utils.To_Html ("x 'item y'' p", SYNTAX_PHPBB),
                                "Italic rendering invalid");
   end Test_Wiki_Italic;

   --  ------------------------------
   --  Test various format rendering.
   --  ------------------------------
   procedure Test_Wiki_Formats (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
itboldem
",
                                Wiki.Utils.To_Html ("_it*bold*em_", SYNTAX_GOOGLE),
                                "Italic+Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item_ y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
   end Test_Wiki_Formats;

   --  ------------------------------
   --  Test heading rendering.
   --  ------------------------------
   procedure Test_Wiki_Section (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("= item =", SYNTAX_GOOGLE),
                                "H1 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("== item == ", SYNTAX_GOOGLE),
                                "H2 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("=== item  ===  ", SYNTAX_GOOGLE),
                                "H3 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("==== item ==== ", SYNTAX_GOOGLE),
                                "H4 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("===== item =====", SYNTAX_GOOGLE),
                                "H5 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("====== item ===", SYNTAX_GOOGLE),
                                "H6 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item

item2
",
                                Wiki.Utils.To_Html ("= item =" & CR & "== item2 ==", SYNTAX_GOOGLE),
                                "H1 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item

item2

item3
",
        Wiki.Utils.To_Html ("= item =" & CR & "== item2 ==" & CR & "= item3 =",
          SYNTAX_GOOGLE),
        "H1 rendering invalid");
   end Test_Wiki_Section;

   --  ------------------------------
   --  Test list rendering.
   --  ------------------------------
   procedure Test_Wiki_List (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html ("# item", SYNTAX_GOOGLE),
                                "Ordered list rendering invalid");
      Util.Tests.Assert_Equals (T, "

item item " & ASCII.LF &
                                "

item2 item2" & ASCII.LF &
                                "

item3

",
        Wiki.Utils.To_Html ("# item item " & LF & "# item2 item2" & LF & "## item3",
         SYNTAX_GOOGLE),
        "Ordered rendering invalid");

      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html (" * item", SYNTAX_GOOGLE),
                                "Bullet list rendering invalid");

      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html ("* item", SYNTAX_DOTCLEAR),
                                "Bullet list rendering invalid");

   end Test_Wiki_List;

   --  ------------------------------
   --  Test link rendering.
   --  ------------------------------
   procedure Test_Wiki_Link (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[name]", SYNTAX_GOOGLE),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[name |http://www.joe.com/item|en|some]",
                                SYNTAX_DOTCLEAR),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[[name]]", SYNTAX_CREOLE),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
[d
",
                                Wiki.Utils.To_Html ("[d", SYNTAX_CREOLE),
                                "No link rendering invalid");
      Util.Tests.Assert_Equals (T, "
http://www.joe.com/item
",
                                Wiki.Utils.To_Html ("[http://www.joe.com/item]",
                                SYNTAX_DOTCLEAR),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[[name]]", SYNTAX_MEDIA_WIKI),
                                "Link rendering invalid");
   end Test_Wiki_Link;

   --  ------------------------------
   --  Test quote rendering.
   --  ------------------------------
   procedure Test_Wiki_Quote (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
<q>quote</q>
",
                                Wiki.Utils.To_Html ("{{quote}}", SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
<q lang=""en"">quote</q>
",
                                Wiki.Utils.To_Html ("{{quote|en}}", SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
<q lang=""en"" cite=""http://www.sun.com"">quote</q>
",
                                Wiki.Utils.To_Html ("{{quote|en|http://www.sun.com}}",
                                                 SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
{quote}}
",
                                Wiki.Utils.To_Html ("{quote}}", SYNTAX_DOTCLEAR),
                                "No quote rendering invalid");
   end Test_Wiki_Quote;

   --  ------------------------------
   --  Test line break rendering.
   --  ------------------------------
   procedure Test_Wiki_Line_Break (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
a
b
",
                                Wiki.Utils.To_Html ("a%%%b", SYNTAX_DOTCLEAR),
                                "Line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a
b
",
                                Wiki.Utils.To_Html ("a\\b", SYNTAX_CREOLE),
                                "Line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a%%b
",
                                Wiki.Utils.To_Html ("a%%b", SYNTAX_DOTCLEAR),
                                "No line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a%b
",
                                Wiki.Utils.To_Html ("a%b", SYNTAX_DOTCLEAR),
                                "No line break rendering invalid");
   end Test_Wiki_Line_Break;

   --  ------------------------------
   --  Test image rendering.
   --  ------------------------------
   procedure Test_Wiki_Image (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png))", SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png|title))", SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png|title|D|describe))",
                                                 SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
   end Test_Wiki_Image;

   --  ------------------------------
   --  Test preformatted rendering.
   --  ------------------------------
   procedure Test_Wiki_Preformatted (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
<tt>code</tt>
",
                                Wiki.Utils.To_Html ("{{{code}}}", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
* code *" & ASCII.LF & "
",
                                Wiki.Utils.To_Html ("///" & LF & "* code *" & LF & "///",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
item1 x" & ASCII.LF & "item2 x" & ASCII.LF & "item3 x"
                                & ASCII.LF & "
",
                                Wiki.Utils.To_Html (" item1 x" & LF & " item2 x" & LF & " item3 x",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
item1 x" & ASCII.LF & "item2 x"
                                & ASCII.LF & "item3 x"
                                & ASCII.LF & "
",
                                Wiki.Utils.To_Html (" item1 x" & CR & LF & " item2 x"
                                  & CR & LF & " item3 x",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
   end Test_Wiki_Preformatted;

   --  ------------------------------
   --  Test the text renderer.
   --  ------------------------------
   procedure Test_Wiki_Text_Renderer (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, ASCII.LF & "code",
                                Wiki.Utils.To_Text ("{{{code}}}", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, ASCII.LF & "bold item my_title" & ASCII.LF,
                                Wiki.Utils.To_Text ("_bold_ __item__ [my_title]", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");

   end Test_Wiki_Text_Renderer;

end Wiki.Parsers.Tests;

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

with Util.Test_Caller;

with Wiki.Utils;
package body Wiki.Parsers.Tests is

   package Caller is new Util.Test_Caller (Test, "Wikis.Parsers");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (bold)",
                       Test_Wiki_Bold'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (italic)",
                       Test_Wiki_Italic'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (italic, bold)",
                       Test_Wiki_Formats'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (headings)",
                       Test_Wiki_Section'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (lists)",
                       Test_Wiki_List'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (links)",
                       Test_Wiki_Link'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (quote)",
                       Test_Wiki_Quote'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (line break)",
                       Test_Wiki_Line_Break'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (image)",
                       Test_Wiki_Image'Access);
      Caller.Add_Test (Suite, "Test Wiki.Parsers.Parse (preformatted)",
                       Test_Wiki_Preformatted'Access);
      Caller.Add_Test (Suite, "Test Wiki.Text.Renderer",
                       Test_Wiki_Text_Renderer'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test bold rendering.
   --  ------------------------------
   procedure Test_Wiki_Bold (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
bold
",
                                Wiki.Utils.To_Html ("*bold*", SYNTAX_GOOGLE),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x *bold* y", SYNTAX_GOOGLE),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x *bold y", SYNTAX_MIX),
                                "Bold rendering invalid (MIX)");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x __item y__ p", SYNTAX_DOTCLEAR),
                                "Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x _item y_ p
",
                                Wiki.Utils.To_Html ("x _item y_ p", SYNTAX_DOTCLEAR),
                                "No bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x bold y
",
                                Wiki.Utils.To_Html ("x '''bold''' y", SYNTAX_PHPBB),
                                "Bold rendering invalid (PHPBB)");
   end Test_Wiki_Bold;

   --  ------------------------------
   --  Test italic rendering.
   --  ------------------------------
   procedure Test_Wiki_Italic (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("_item_", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item_ y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item y", SYNTAX_MIX),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x ''item y'' p", SYNTAX_DOTCLEAR),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y p
",
                                Wiki.Utils.To_Html ("x ''item y'' p", SYNTAX_PHPBB),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x 'item y p
",
                                Wiki.Utils.To_Html ("x 'item y'' p", SYNTAX_PHPBB),
                                "Italic rendering invalid");
   end Test_Wiki_Italic;

   --  ------------------------------
   --  Test various format rendering.
   --  ------------------------------
   procedure Test_Wiki_Formats (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
itboldem
",
                                Wiki.Utils.To_Html ("_it*bold*em_", SYNTAX_GOOGLE),
                                "Italic+Bold rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item_ y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
      Util.Tests.Assert_Equals (T, "
x item y
",
                                Wiki.Utils.To_Html ("x _item y", SYNTAX_GOOGLE),
                                "Italic rendering invalid");
   end Test_Wiki_Formats;

   --  ------------------------------
   --  Test heading rendering.
   --  ------------------------------
   procedure Test_Wiki_Section (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("= item =", SYNTAX_GOOGLE),
                                "H1 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("== item == ", SYNTAX_GOOGLE),
                                "H2 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("=== item  ===  ", SYNTAX_GOOGLE),
                                "H3 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("==== item ==== ", SYNTAX_GOOGLE),
                                "H4 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("===== item =====", SYNTAX_GOOGLE),
                                "H5 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item
",
                                Wiki.Utils.To_Html ("====== item ===", SYNTAX_GOOGLE),
                                "H6 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item

item2
",
                                Wiki.Utils.To_Html ("= item =" & CR & "== item2 ==",
                                  SYNTAX_GOOGLE),
                                "H1 rendering invalid");
      Util.Tests.Assert_Equals (T, "
item

item2

item3
",
        Wiki.Utils.To_Html ("= item =" & CR & "== item2 ==" & CR & "= item3 =",
          SYNTAX_GOOGLE),
        "H1 rendering invalid");
   end Test_Wiki_Section;

   --  ------------------------------
   --  Test list rendering.
   --  ------------------------------
   procedure Test_Wiki_List (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html ("# item", SYNTAX_GOOGLE),
                                "Ordered list rendering invalid");
      Util.Tests.Assert_Equals (T, "

item item " & ASCII.LF &
                                "

item2 item2" & ASCII.LF &
                                "

item3

",
        Wiki.Utils.To_Html ("# item item " & LF & "# item2 item2" & LF & "## item3",
         SYNTAX_GOOGLE),
        "Ordered rendering invalid");

      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html (" * item", SYNTAX_GOOGLE),
                                "Bullet list rendering invalid");

      Util.Tests.Assert_Equals (T, "

item

",
                                Wiki.Utils.To_Html ("* item", SYNTAX_DOTCLEAR),
                                "Bullet list rendering invalid");

   end Test_Wiki_List;

   --  ------------------------------
   --  Test link rendering.
   --  ------------------------------
   procedure Test_Wiki_Link (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[name]", SYNTAX_GOOGLE),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[name |http://www.joe.com/item|en|some]",
                                SYNTAX_DOTCLEAR),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[[name]]", SYNTAX_CREOLE),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
[d
",
                                Wiki.Utils.To_Html ("[d", SYNTAX_CREOLE),
                                "No link rendering invalid");
      Util.Tests.Assert_Equals (T, "
http://www.joe.com/item
",
                                Wiki.Utils.To_Html ("[http://www.joe.com/item]",
                                SYNTAX_DOTCLEAR),
                                "Link rendering invalid");
      Util.Tests.Assert_Equals (T, "
name
",
                                Wiki.Utils.To_Html ("[[name]]", SYNTAX_MEDIA_WIKI),
                                "Link rendering invalid");
   end Test_Wiki_Link;

   --  ------------------------------
   --  Test quote rendering.
   --  ------------------------------
   procedure Test_Wiki_Quote (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
<q>quote</q>
",
                                Wiki.Utils.To_Html ("{{quote}}", SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
<q lang=""en"">quote</q>
",
                                Wiki.Utils.To_Html ("{{quote|en}}", SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
<q lang=""en"" cite=""http://www.sun.com"">quote</q>
",
                                Wiki.Utils.To_Html ("{{quote|en|http://www.sun.com}}",
                                                 SYNTAX_DOTCLEAR),
                                "Quote rendering invalid");
      Util.Tests.Assert_Equals (T, "
{quote}}
",
                                Wiki.Utils.To_Html ("{quote}}", SYNTAX_DOTCLEAR),
                                "No quote rendering invalid");
   end Test_Wiki_Quote;

   --  ------------------------------
   --  Test line break rendering.
   --  ------------------------------
   procedure Test_Wiki_Line_Break (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
a
b
",
                                Wiki.Utils.To_Html ("a%%%b", SYNTAX_DOTCLEAR),
                                "Line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a
b
",
                                Wiki.Utils.To_Html ("a\\b", SYNTAX_CREOLE),
                                "Line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a%%b
",
                                Wiki.Utils.To_Html ("a%%b", SYNTAX_DOTCLEAR),
                                "No line break rendering invalid");
      Util.Tests.Assert_Equals (T, "
a%b
",
                                Wiki.Utils.To_Html ("a%b", SYNTAX_DOTCLEAR),
                                "No line break rendering invalid");
   end Test_Wiki_Line_Break;

   --  ------------------------------
   --  Test image rendering.
   --  ------------------------------
   procedure Test_Wiki_Image (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png))", SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png|title))", SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
      Util.Tests.Assert_Equals (T, "

",
                                Wiki.Utils.To_Html ("((/image/t.png|title|D|describe))",
                                                 SYNTAX_DOTCLEAR),
                                "Image rendering invalid");
   end Test_Wiki_Image;

   --  ------------------------------
   --  Test preformatted rendering.
   --  ------------------------------
   procedure Test_Wiki_Preformatted (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, "
<tt>code</tt>
",
                                Wiki.Utils.To_Html ("{{{code}}}", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
* code *" & ASCII.LF & "
",
                                Wiki.Utils.To_Html ("///" & LF & "* code *" & LF & "///",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
item1 x" & ASCII.LF & "item2 x" & ASCII.LF & "item3 x"
                                & ASCII.LF & "
",
                                Wiki.Utils.To_Html (" item1 x" & LF & " item2 x" & LF & " item3 x",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, "
item1 x" & ASCII.LF & "item2 x"
                                & ASCII.LF & "item3 x"
                                & ASCII.LF & "
",
                                Wiki.Utils.To_Html (" item1 x" & CR & LF & " item2 x"
                                  & CR & LF & " item3 x",
                                                 SYNTAX_DOTCLEAR),
                                "Preformat rendering invalid");
   end Test_Wiki_Preformatted;

   --  ------------------------------
   --  Test the text renderer.
   --  ------------------------------
   procedure Test_Wiki_Text_Renderer (T : in out Test) is
   begin
      Util.Tests.Assert_Equals (T, ASCII.LF & "code",
                                Wiki.Utils.To_Text ("{{{code}}}", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");
      Util.Tests.Assert_Equals (T, ASCII.LF & "bold item my_title" & ASCII.LF,
                                Wiki.Utils.To_Text ("_bold_ __item__ [my_title]", SYNTAX_GOOGLE),
                                "Preformat rendering invalid");

   end Test_Wiki_Text_Renderer;

end Wiki.Parsers.Tests;

Fix compilation warning

Fix compilation warning


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

with AWA.Services.Contexts;
with AWA.Blogs.Services;
with AWA.Helpers.Selectors;

with ADO.Queries;
with ADO.Sessions;
with ADO.Sessions.Entities;

with ASF.Contexts.Faces;
with ASF.Applications.Messages.Factory;
with ASF.Events.Faces.Actions;
package body AWA.Blogs.Beans is

   use Ada.Strings.Unbounded;

   BLOG_ID_PARAMETER : constant String := "blog_id";
   POST_ID_PARAMETER : constant String := "post_id";

   function Get_Parameter (Name : in String) return ADO.Identifier;

   --  ------------------------------
   --  Get the parameter identified by the given name and return it as an identifier.
   --  Returns NO_IDENTIFIER if the parameter does not exist or is not valid.
   --  ------------------------------
   function Get_Parameter (Name : in String) return ADO.Identifier is
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Ctx  : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      if Ctx = null then
         return ADO.NO_IDENTIFIER;
      else
         declare
            P    : constant String := Ctx.Get_Parameter (Name);
         begin
            if P = "" then
               return ADO.NO_IDENTIFIER;
            else
               return ADO.Identifier'Value (P);
            end if;
         end;
      end if;
   exception
      when others =>
         return ADO.NO_IDENTIFIER;
   end Get_Parameter;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Blogs.Models.Blog_Ref (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   package Create_Blog_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Blog_Bean,
                                                      Method => Create_Blog,
                                                      Name   => "create");

   Blog_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Blog_Binding.Proxy'Access);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Blog_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Blog_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a new blog.
   --  ------------------------------
   procedure Create_Blog (Bean    : in out Blog_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Manager : constant AWA.Blogs.Services.Blog_Service_Access := Bean.Module.Get_Blog_Manager;
      Result  : ADO.Identifier;
   begin
      Manager.Create_Blog (Workspace_Id => 0,
                           Title        => Bean.Get_Name,
                           Result       => Result);
      Outcome := To_Unbounded_String ("success");

   exception
      when Services.Not_Found =>
         Outcome := To_Unbounded_String ("failure");

         ASF.Applications.Messages.Factory.Add_Message ("users.signup_error_message");
   end Create_Blog;

   --  ------------------------------
   --  Create the Blog_Bean bean instance.
   --  ------------------------------
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      use type ADO.Identifier;

      Blog_Id : constant ADO.Identifier := Get_Parameter (BLOG_ID_PARAMETER);
      Object  : constant Blog_Bean_Access := new Blog_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
   begin
      if Blog_Id > 0 then
         Object.Load (Session, Blog_Id);
      end if;
      Object.Module := Module;
      return Object.all'Access;
   end Create_Blog_Bean;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Create_Post (Bean    : in out Post_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type ADO.Identifier;

      Manager : constant AWA.Blogs.Services.Blog_Service_Access := Bean.Module.Get_Blog_Manager;
      Result  : ADO.Identifier;
      Blog_Id : constant ADO.Identifier := Get_Parameter (BLOG_ID_PARAMETER);
      Post_Id : constant ADO.Identifier := Get_Parameter (POST_ID_PARAMETER);
   begin
      if Post_Id < 0 then
         Manager.Create_Post (Blog_Id => Blog_Id,
                              Title   => Bean.Post.Get_Title,
                              URI     => Bean.Post.Get_Uri,
                              Text    => Bean.Post.Get_Text,
                              Status  => Bean.Post.Get_Status,
                              Result  => Result);
      else
         Manager.Update_Post (Post_Id => Post_Id,
                              Title   => Bean.Post.Get_Title,
                              Text    => Bean.Post.Get_Text,
                              Status  => Bean.Post.Get_Status);
      end if;
      Outcome := To_Unbounded_String ("success");

   exception
      when Services.Not_Found =>
         Outcome := To_Unbounded_String ("failure");

         ASF.Applications.Messages.Factory.Add_Message ("users.signup_error_message");
   end Create_Post;

   package Create_Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Post_Bean,
                                                      Method => Create_Post,
                                                      Name   => "create");

   package Save_Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Post_Bean,
                                                      Method => Create_Post,
                                                      Name   => "save");

   Post_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Post_Binding.Proxy'Access,
         2 => Save_Post_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = BLOG_ID_ATTR then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Blog_Id));
      elsif Name = POST_ID_ATTR then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Post.Get_Id));
      elsif Name = POST_USERNAME_ATTR then
         return Util.Beans.Objects.To_Object (String '(From.Post.Get_Author.Get_Name));
      else
         return From.Post.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = BLOG_ID_ATTR then
         From.Blog_Id := ADO.Identifier (Util.Beans.Objects.To_Integer (Value));
      elsif Name = POST_ID_ATTR then
         From.Blog_Id := ADO.Identifier (Util.Beans.Objects.To_Integer (Value));
      elsif Name = POST_TEXT_ATTR then
         From.Post.Set_Text (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_TITLE_ATTR then
         From.Post.Set_Title (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_URI_ATTR then
         From.Post.Set_Uri (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_STATUS_ATTR then
         From.Post.Set_Status (AWA.Blogs.Models.Post_Status_Type_Objects.To_Value (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Post_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Post_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      use type ADO.Identifier;

      Object  : constant Post_Bean_Access := new Post_Bean;
      Post_Id : constant ADO.Identifier := Get_Parameter (POST_ID_PARAMETER);
   begin
      if Post_Id > 0 then
         declare
            Session : ADO.Sessions.Session := Module.Get_Session;
         begin
            Object.Post.Load (Session, Post_Id);
            Object.Title := Object.Post.Get_Title;
            Object.Text  := Object.Post.Get_Text;
            Object.URI   := Object.Post.Get_Uri;

            --  SCz: 2012-05-19: workaround for ADO 0.3 limitation.  The lazy loading of
            --  objects does not work yet.  Force loading the user here while the above
            --  session is still open.
            declare
               A : constant String := String '(Object.Post.Get_Author.Get_Name);
               pragma Unreferenced (A);
            begin
               null;
            end;
         end;
      end if;
      Object.Module := Module;
      return Object.all'Access;
   end Create_Post_Bean;

   --  ------------------------------
   --  Create the Post_List_Bean bean instance.
   --  ------------------------------
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;

      Object  : constant Post_Info_List_Bean_Access := new Post_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Blogs.Models.Query_Blog_Post_List);
      AWA.Blogs.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Post_List_Bean;

   --  ------------------------------
   --  Create the Admin_Post_List_Bean bean instance.
   --  ------------------------------
   function Create_Admin_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                         return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;

      Object  : constant Admin_Post_Info_List_Bean_Access := new Admin_Post_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
      Blog_Id : constant ADO.Identifier := Get_Parameter (BLOG_ID_PARAMETER);
   begin
      if Blog_Id > 0 then
         Query.Set_Query (AWA.Blogs.Models.Query_Blog_Admin_Post_List);
         Query.Bind_Param ("blog_id", Blog_Id);
         Query.Bind_Param ("user_id", User);
         ADO.Sessions.Entities.Bind_Param (Query, "table",
                                           AWA.Blogs.Models.BLOG_TABLE'Access, Session);
         AWA.Blogs.Models.List (Object.all, Session, Query);
      end if;
      return Object.all'Access;
   end Create_Admin_Post_List_Bean;

   --  ------------------------------
   --  Create the Blog_List_Bean bean instance.
   --  ------------------------------
   function Create_Blog_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Object  : constant Blog_Info_List_Bean_Access := new Blog_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Blogs.Models.Query_Blog_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Blogs.Models.BLOG_TABLE'Access, Session);
      AWA.Blogs.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Blog_List_Bean;

   function Create_From_Status is
     new AWA.Helpers.Selectors.Create_From_Enum (AWA.Blogs.Models.Post_Status_Type,
                                                 "blog_status_");

   --  ------------------------------
   --  Get a select item list which contains a list of post status.
   --  ------------------------------
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Helpers;
   begin
      return Selectors.Create_Selector_Bean (Bundle  => "blogs",
                                             Context => null,
                                             Create  => Create_From_Status'Access).all'Access;
   end Create_Status_List;

end AWA.Blogs.Beans;

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

with AWA.Services.Contexts;
with AWA.Blogs.Services;
with AWA.Helpers.Requests;
with AWA.Helpers.Selectors;

with ADO.Queries;
with ADO.Sessions;
with ADO.Sessions.Entities;

with ASF.Applications.Messages.Factory;
with ASF.Events.Faces.Actions;
package body AWA.Blogs.Beans is

   use Ada.Strings.Unbounded;

   BLOG_ID_PARAMETER : constant String := "blog_id";
   POST_ID_PARAMETER : constant String := "post_id";

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return AWA.Blogs.Models.Blog_Ref (From).Get_Value (Name);
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "name" then
         From.Set_Name (Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   package Create_Blog_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Blog_Bean,
                                                      Method => Create_Blog,
                                                      Name   => "create");

   Blog_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Blog_Binding.Proxy'Access);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Blog_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Blog_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create a new blog.
   --  ------------------------------
   procedure Create_Blog (Bean    : in out Blog_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Manager : constant AWA.Blogs.Services.Blog_Service_Access := Bean.Module.Get_Blog_Manager;
      Result  : ADO.Identifier;
   begin
      Manager.Create_Blog (Workspace_Id => 0,
                           Title        => Bean.Get_Name,
                           Result       => Result);
      Outcome := To_Unbounded_String ("success");

   exception
      when Services.Not_Found =>
         Outcome := To_Unbounded_String ("failure");

         ASF.Applications.Messages.Factory.Add_Message ("users.signup_error_message");
   end Create_Blog;

   --  ------------------------------
   --  Create the Blog_Bean bean instance.
   --  ------------------------------
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      use type ADO.Identifier;

      Blog_Id : constant ADO.Identifier := AWA.Helpers.Requests.Get_Parameter (BLOG_ID_PARAMETER);
      Object  : constant Blog_Bean_Access := new Blog_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
   begin
      if Blog_Id > 0 then
         Object.Load (Session, Blog_Id);
      end if;
      Object.Module := Module;
      return Object.all'Access;
   end Create_Blog_Bean;

   --  ------------------------------
   --  Example of action method.
   --  ------------------------------
   procedure Create_Post (Bean    : in out Post_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      use type ADO.Identifier;

      Manager : constant AWA.Blogs.Services.Blog_Service_Access := Bean.Module.Get_Blog_Manager;
      Result  : ADO.Identifier;
      Blog_Id : constant ADO.Identifier := AWA.Helpers.Requests.Get_Parameter (BLOG_ID_PARAMETER);
      Post_Id : constant ADO.Identifier := AWA.Helpers.Requests.Get_Parameter (POST_ID_PARAMETER);
   begin
      if Post_Id < 0 then
         Manager.Create_Post (Blog_Id => Blog_Id,
                              Title   => Bean.Post.Get_Title,
                              URI     => Bean.Post.Get_Uri,
                              Text    => Bean.Post.Get_Text,
                              Status  => Bean.Post.Get_Status,
                              Result  => Result);
      else
         Manager.Update_Post (Post_Id => Post_Id,
                              Title   => Bean.Post.Get_Title,
                              Text    => Bean.Post.Get_Text,
                              Status  => Bean.Post.Get_Status);
      end if;
      Outcome := To_Unbounded_String ("success");

   exception
      when Services.Not_Found =>
         Outcome := To_Unbounded_String ("failure");

         ASF.Applications.Messages.Factory.Add_Message ("users.signup_error_message");
   end Create_Post;

   package Create_Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Post_Bean,
                                                      Method => Create_Post,
                                                      Name   => "create");

   package Save_Post_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Post_Bean,
                                                      Method => Create_Post,
                                                      Name   => "save");

   Post_Bean_Binding : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Create_Post_Binding.Proxy'Access,
         2 => Save_Post_Binding.Proxy'Access);

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = BLOG_ID_ATTR then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Blog_Id));
      elsif Name = POST_ID_ATTR then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Post.Get_Id));
      elsif Name = POST_USERNAME_ATTR then
         return Util.Beans.Objects.To_Object (String '(From.Post.Get_Author.Get_Name));
      else
         return From.Post.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = BLOG_ID_ATTR then
         From.Blog_Id := ADO.Identifier (Util.Beans.Objects.To_Integer (Value));
      elsif Name = POST_ID_ATTR then
         From.Blog_Id := ADO.Identifier (Util.Beans.Objects.To_Integer (Value));
      elsif Name = POST_TEXT_ATTR then
         From.Post.Set_Text (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_TITLE_ATTR then
         From.Post.Set_Title (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_URI_ATTR then
         From.Post.Set_Uri (Util.Beans.Objects.To_Unbounded_String (Value));
      elsif Name = POST_STATUS_ATTR then
         From.Post.Set_Status (AWA.Blogs.Models.Post_Status_Type_Objects.To_Value (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in Post_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Post_Bean_Binding'Access;
   end Get_Method_Bindings;

   --  ------------------------------
   --  Create the Workspaces_Bean bean instance.
   --  ------------------------------
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access is
      use type ADO.Identifier;

      Object  : constant Post_Bean_Access := new Post_Bean;
      Post_Id : constant ADO.Identifier := AWA.Helpers.Requests.Get_Parameter (POST_ID_PARAMETER);
   begin
      if Post_Id > 0 then
         declare
            Session : ADO.Sessions.Session := Module.Get_Session;
         begin
            Object.Post.Load (Session, Post_Id);
            Object.Title := Object.Post.Get_Title;
            Object.Text  := Object.Post.Get_Text;
            Object.URI   := Object.Post.Get_Uri;

            --  SCz: 2012-05-19: workaround for ADO 0.3 limitation.  The lazy loading of
            --  objects does not work yet.  Force loading the user here while the above
            --  session is still open.
            declare
               A : constant String := String '(Object.Post.Get_Author.Get_Name);
               pragma Unreferenced (A);
            begin
               null;
            end;
         end;
      end if;
      Object.Module := Module;
      return Object.all'Access;
   end Create_Post_Bean;

   --  ------------------------------
   --  Create the Post_List_Bean bean instance.
   --  ------------------------------
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;

      Object  : constant Post_Info_List_Bean_Access := new Post_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Blogs.Models.Query_Blog_Post_List);
      AWA.Blogs.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Post_List_Bean;

   --  ------------------------------
   --  Create the Admin_Post_List_Bean bean instance.
   --  ------------------------------
   function Create_Admin_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                         return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Ctx   : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;

      Object  : constant Admin_Post_Info_List_Bean_Access := new Admin_Post_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
      Blog_Id : constant ADO.Identifier := AWA.Helpers.Requests.Get_Parameter (BLOG_ID_PARAMETER);
   begin
      if Blog_Id > 0 then
         Query.Set_Query (AWA.Blogs.Models.Query_Blog_Admin_Post_List);
         Query.Bind_Param ("blog_id", Blog_Id);
         Query.Bind_Param ("user_id", User);
         ADO.Sessions.Entities.Bind_Param (Query, "table",
                                           AWA.Blogs.Models.BLOG_TABLE'Access, Session);
         AWA.Blogs.Models.List (Object.all, Session, Query);
      end if;
      return Object.all'Access;
   end Create_Admin_Post_List_Bean;

   --  ------------------------------
   --  Create the Blog_List_Bean bean instance.
   --  ------------------------------
   function Create_Blog_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Blogs.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Ctx     : constant Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant ADO.Identifier := Ctx.Get_User_Identifier;
      Object  : constant Blog_Info_List_Bean_Access := new Blog_Info_List_Bean;
      Session : ADO.Sessions.Session := Module.Get_Session;
      Query   : ADO.Queries.Context;
   begin
      Query.Set_Query (AWA.Blogs.Models.Query_Blog_List);
      Query.Bind_Param ("user_id", User);
      ADO.Sessions.Entities.Bind_Param (Query, "table",
                                        AWA.Blogs.Models.BLOG_TABLE'Access, Session);
      AWA.Blogs.Models.List (Object.all, Session, Query);
      return Object.all'Access;
   end Create_Blog_List_Bean;

   function Create_From_Status is
     new AWA.Helpers.Selectors.Create_From_Enum (AWA.Blogs.Models.Post_Status_Type,
                                                 "blog_status_");

   --  ------------------------------
   --  Get a select item list which contains a list of post status.
   --  ------------------------------
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      pragma Unreferenced (Module);
      use AWA.Helpers;
   begin
      return Selectors.Create_Selector_Bean (Bundle  => "blogs",
                                             Context => null,
                                             Create  => Create_From_Status'Access).all'Access;
   end Create_Status_List;

end AWA.Blogs.Beans;

Use the AWA.Helpers.Requests package

Use the AWA.Helpers.Requests package