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

with Ada.Characters.Conversions;
package body ASF.Models.Selects is

   --  ------------------------------
   --  Return an Object from the select item record.
   --  Returns a NULL object if the item is empty.
   --  ------------------------------
   function To_Object (Item : in Select_Item) return Util.Beans.Objects.Object is
   begin
      if Item.Item.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Bean : constant Select_Item_Access := new Select_Item;
         begin
            Bean.all := Item;
            return Util.Beans.Objects.To_Object (Bean.all'Access);
         end;
      end if;
   end To_Object;

   --  ------------------------------
   --  Return the Select_Item instance from a generic bean object.
   --  Returns an empty item if the object does not hold a Select_Item.
   --  ------------------------------
   function To_Select_Item (Object : in Util.Beans.Objects.Object) return Select_Item is
      Bean   : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Object);
      Result : Select_Item;
   begin
      if Bean = null then
         return Result;
      end if;
      if not (Bean.all in Select_Item'Class) then
         return Result;
      end if;
      Result := Select_Item (Bean.all);
      return Result;
   end To_Select_Item;

   --  ------------------------------
   --  Creates a Select_Item with the specified label and value.
   --  ------------------------------
   function Create_Select_Item (Label       : in String;
                                Value       : in String;
                                Description : in String := "";
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item is
      use Ada.Characters.Conversions;

      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         Item.Label       := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Label));
         Item.Value       := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Value));
         Item.Description := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Description));
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item;

   --  ------------------------------
   --  Creates a Select_Item with the specified label and value.
   --  ------------------------------
   function Create_Select_Item_Wide (Label       : in Wide_Wide_String;
                                     Value       : in Wide_Wide_String;
                                     Description : in Wide_Wide_String := "";
                                     Disabled    : in Boolean := False;
                                     Escaped     : in Boolean := True) return Select_Item is
      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         Item.Label       := To_Unbounded_Wide_Wide_String (Label);
         Item.Value       := To_Unbounded_Wide_Wide_String (Value);
         Item.Description := To_Unbounded_Wide_Wide_String (Description);
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item_Wide;

   --  ------------------------------
   --  Creates a Select_Item with the specified label, value and description.
   --  The objects are converted to a wide wide string.  The empty string is used if they
   --  are null.
   --  ------------------------------
   function Create_Select_Item (Label       : in Util.Beans.Objects.Object;
                                Value       : in Util.Beans.Objects.Object;
                                Description : in Util.Beans.Objects.Object;
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item is
      use Util.Beans.Objects;

      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         if not Is_Null (Label) then
            Item.Label       := To_Unbounded_Wide_Wide_String (Label);
         end if;
         if not Is_Null (Value) then
            Item.Value       := To_Unbounded_Wide_Wide_String (Value);
         end if;
         if not Is_Null (Description) then
            Item.Description := To_Unbounded_Wide_Wide_String (Description);
         end if;
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item;

   --  ------------------------------
   --  Get the item label.
   --  ------------------------------
   function Get_Label (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Label);
      end if;
   end Get_Label;

   --  ------------------------------
   --  Get the item value.
   --  ------------------------------
   function Get_Value (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Value);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the item description.
   --  ------------------------------
   function Get_Description (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Description);
      end if;
   end Get_Description;

   --  ------------------------------
   --  Returns true if the item is disabled.
   --  ------------------------------
   function Is_Disabled (Item : in Select_Item) return Boolean is
   begin
      if Item.Item.Is_Null then
         return False;
      else
         return Item.Item.Value.Disabled;
      end if;
   end Is_Disabled;

   --  ------------------------------
   --  Returns true if the label must be escaped using HTML escape rules.
   --  ------------------------------
   function Is_Escaped (Item : in Select_Item) return Boolean is
   begin
      if Item.Item.Is_Null then
         return False;
      else
         return Item.Item.Value.Escape;
      end if;
   end Is_Escaped;

   --  ------------------------------
   --  Returns true if the select item component is empty.
   --  ------------------------------
   function Is_Empty (Item : in Select_Item) return Boolean is
   begin
      return Item.Item.Is_Null;
   end Is_Empty;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Select_Item;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Item.Is_Null then
         return Util.Beans.Objects.Null_Object;
      end if;
      declare
         Item : constant Select_Item_Record_Access := From.Item.Value;
      begin
         if Name = "name" then
            return Util.Beans.Objects.To_Object (Item.Label);
         elsif Name = "value" then
            return Util.Beans.Objects.To_Object (Item.Value);
         elsif Name = "description" then
            return Util.Beans.Objects.To_Object (Item.Description);
         elsif Name = "disabled" then
            return Util.Beans.Objects.To_Object (Item.Disabled);
         elsif Name = "escaped" then
            return Util.Beans.Objects.To_Object (Item.Escape);
         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end;
   end Get_Value;

   --  ------------------------------
   --  Select Item List
   --  ------------------------------

   --  ------------------------------
   --  Return an Object from the select item list.
   --  Returns a NULL object if the list is empty.
   --  ------------------------------
   function To_Object (Item : in Select_Item_List) return Util.Beans.Objects.Object is
   begin
      if Item.List.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Bean : constant Select_Item_List_Access := new Select_Item_List;
         begin
            Bean.all := Item;
            return Util.Beans.Objects.To_Object (Bean.all'Access);
         end;
      end if;
   end To_Object;

   --  ------------------------------
   --  Return the Select_Item_List instance from a generic bean object.
   --  Returns an empty list if the object does not hold a Select_Item_List.
   --  ------------------------------
   function To_Select_Item_List (Object : in Util.Beans.Objects.Object) return Select_Item_List is
      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Object);
      Result : Select_Item_List;
   begin
      if Bean = null then
         return Result;
      end if;
      if not (Bean.all in Select_Item_List'Class) then
         return Result;
      end if;
      Result := Select_Item_List (Bean.all);
      return Result;
   end To_Select_Item_List;

   --  ------------------------------
   --  Get the number of items in the list.
   --  ------------------------------
   function Length (List : in Select_Item_List) return Natural is
   begin
      if List.List.Is_Null then
         return 0;
      else
         return Natural (List.List.Value.List.Length);
      end if;
   end Length;

   --  ------------------------------
   --  Get the select item from the list
   --  ------------------------------
   function Get_Select_Item (List : in Select_Item_List'Class;
                             Pos  : in Positive) return Select_Item is
   begin
      if List.List.Is_Null then
         raise Constraint_Error with "Select item list is empty";
      end if;
      return List.List.Value.List.Element (Pos);
   end Get_Select_Item;

   --  ------------------------------
   --  Add the item at the end of the list.
   --  ------------------------------
   procedure Append (List : in out Select_Item_List;
                     Item : in Select_Item'Class) is
   begin
      if List.List.Is_Null then
         List.List := Select_Item_Vector_Refs.Create;
      end if;
      List.List.Value.all.List.Append (Select_Item (Item));
   end Append;

   --  ------------------------------
   --  Add the item at the end of the list.  This is a shortcut for
   --  Append (Create_List_Item (Label, Value))
   --  ------------------------------
   procedure Append (List  : in out Select_Item_List;
                     Label : in String;
                     Value : in String) is
   begin
      List.Append (Create_Select_Item (Label, Value));
   end Append;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Select_Item_List;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

end ASF.Models.Selects;

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

with Ada.Characters.Conversions;
package body ASF.Models.Selects is

   --  ------------------------------
   --  Return an Object from the select item record.
   --  Returns a NULL object if the item is empty.
   --  ------------------------------
   function To_Object (Item : in Select_Item) return Util.Beans.Objects.Object is
   begin
      if Item.Item.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Bean : constant Select_Item_Access := new Select_Item;
         begin
            Bean.all := Item;
            return Util.Beans.Objects.To_Object (Bean.all'Access);
         end;
      end if;
   end To_Object;

   --  ------------------------------
   --  Return the Select_Item instance from a generic bean object.
   --  Returns an empty item if the object does not hold a Select_Item.
   --  ------------------------------
   function To_Select_Item (Object : in Util.Beans.Objects.Object) return Select_Item is
      Bean   : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Object);
      Result : Select_Item;
   begin
      if Bean = null then
         return Result;
      end if;
      if not (Bean.all in Select_Item'Class) then
         return Result;
      end if;
      Result := Select_Item (Bean.all);
      return Result;
   end To_Select_Item;

   --  ------------------------------
   --  Creates a Select_Item with the specified label and value.
   --  ------------------------------
   function Create_Select_Item (Label       : in String;
                                Value       : in String;
                                Description : in String := "";
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item is
      use Ada.Characters.Conversions;

      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         Item.Label       := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Label));
         Item.Value       := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Value));
         Item.Description := To_Unbounded_Wide_Wide_String (To_Wide_Wide_String (Description));
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item;

   --  ------------------------------
   --  Creates a Select_Item with the specified label and value.
   --  ------------------------------
   function Create_Select_Item_Wide (Label       : in Wide_Wide_String;
                                     Value       : in Wide_Wide_String;
                                     Description : in Wide_Wide_String := "";
                                     Disabled    : in Boolean := False;
                                     Escaped     : in Boolean := True) return Select_Item is
      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         Item.Label       := To_Unbounded_Wide_Wide_String (Label);
         Item.Value       := To_Unbounded_Wide_Wide_String (Value);
         Item.Description := To_Unbounded_Wide_Wide_String (Description);
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item_Wide;

   --  ------------------------------
   --  Creates a Select_Item with the specified label, value and description.
   --  The objects are converted to a wide wide string.  The empty string is used if they
   --  are null.
   --  ------------------------------
   function Create_Select_Item (Label       : in Util.Beans.Objects.Object;
                                Value       : in Util.Beans.Objects.Object;
                                Description : in Util.Beans.Objects.Object;
                                Disabled    : in Boolean := False;
                                Escaped     : in Boolean := True) return Select_Item is
      use Util.Beans.Objects;

      Result : Select_Item;
   begin
      Result.Item := Select_Item_Refs.Create;
      declare
         Item : constant Select_Item_Record_Access := Result.Item.Value;
      begin
         if not Is_Null (Label) then
            Item.Label       := To_Unbounded_Wide_Wide_String (Label);
         end if;
         if not Is_Null (Value) then
            Item.Value       := To_Unbounded_Wide_Wide_String (Value);
         end if;
         if not Is_Null (Description) then
            Item.Description := To_Unbounded_Wide_Wide_String (Description);
         end if;
         Item.Disabled    := Disabled;
         Item.Escape      := Escaped;
      end;
      return Result;
   end Create_Select_Item;

   --  ------------------------------
   --  Get the item label.
   --  ------------------------------
   function Get_Label (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Label);
      end if;
   end Get_Label;

   --  ------------------------------
   --  Get the item value.
   --  ------------------------------
   function Get_Value (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Value);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the item description.
   --  ------------------------------
   function Get_Description (Item : in Select_Item) return Wide_Wide_String is
   begin
      if Item.Item.Is_Null then
         return "";
      else
         return To_Wide_Wide_String (Item.Item.Value.Description);
      end if;
   end Get_Description;

   --  ------------------------------
   --  Returns true if the item is disabled.
   --  ------------------------------
   function Is_Disabled (Item : in Select_Item) return Boolean is
   begin
      if Item.Item.Is_Null then
         return False;
      else
         return Item.Item.Value.Disabled;
      end if;
   end Is_Disabled;

   --  ------------------------------
   --  Returns true if the label must be escaped using HTML escape rules.
   --  ------------------------------
   function Is_Escaped (Item : in Select_Item) return Boolean is
   begin
      if Item.Item.Is_Null then
         return False;
      else
         return Item.Item.Value.Escape;
      end if;
   end Is_Escaped;

   --  ------------------------------
   --  Returns true if the select item component is empty.
   --  ------------------------------
   function Is_Empty (Item : in Select_Item) return Boolean is
   begin
      return Item.Item.Is_Null;
   end Is_Empty;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Select_Item;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Item.Is_Null then
         return Util.Beans.Objects.Null_Object;
      end if;
      declare
         Item : constant Select_Item_Record_Access := From.Item.Value;
      begin
         if Name = "name" then
            return Util.Beans.Objects.To_Object (Item.Label);
         elsif Name = "value" then
            return Util.Beans.Objects.To_Object (Item.Value);
         elsif Name = "description" then
            return Util.Beans.Objects.To_Object (Item.Description);
         elsif Name = "disabled" then
            return Util.Beans.Objects.To_Object (Item.Disabled);
         elsif Name = "escaped" then
            return Util.Beans.Objects.To_Object (Item.Escape);
         else
            return Util.Beans.Objects.Null_Object;
         end if;
      end;
   end Get_Value;

   --  ------------------------------
   --  Select Item List
   --  ------------------------------

   --  ------------------------------
   --  Return an Object from the select item list.
   --  Returns a NULL object if the list is empty.
   --  ------------------------------
   function To_Object (Item : in Select_Item_List) return Util.Beans.Objects.Object is
   begin
      if Item.List.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         declare
            Bean : constant Select_Item_List_Access := new Select_Item_List;
         begin
            Bean.all := Item;
            return Util.Beans.Objects.To_Object (Bean.all'Access);
         end;
      end if;
   end To_Object;

   --  ------------------------------
   --  Return the Select_Item_List instance from a generic bean object.
   --  Returns an empty list if the object does not hold a Select_Item_List.
   --  ------------------------------
   function To_Select_Item_List (Object : in Util.Beans.Objects.Object) return Select_Item_List is
      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Object);
      Result : Select_Item_List;
   begin
      if Bean = null then
         return Result;
      end if;
      if not (Bean.all in Select_Item_List'Class) then
         return Result;
      end if;
      Result := Select_Item_List (Bean.all);
      return Result;
   end To_Select_Item_List;

   --  ------------------------------
   --  Get the number of items in the list.
   --  ------------------------------
   function Length (List : in Select_Item_List) return Natural is
   begin
      if List.List.Is_Null then
         return 0;
      else
         return Natural (List.List.Value.List.Length);
      end if;
   end Length;

   --  ------------------------------
   --  Get the select item from the list
   --  ------------------------------
   function Get_Select_Item (List : in Select_Item_List'Class;
                             Pos  : in Positive) return Select_Item is
   begin
      if List.List.Is_Null then
         raise Constraint_Error with "Select item list is empty";
      end if;
      return List.List.Value.List.Element (Pos);
   end Get_Select_Item;

   --  ------------------------------
   --  Add the item at the end of the list.
   --  ------------------------------
   procedure Append (List : in out Select_Item_List;
                     Item : in Select_Item'Class) is
   begin
      if List.List.Is_Null then
         List.List := Select_Item_Vector_Refs.Create;
      end if;
      List.List.Value.all.List.Append (Select_Item (Item));
   end Append;

   --  ------------------------------
   --  Add the item at the end of the list.  This is a shortcut for
   --  Append (Create_List_Item (Label, Value))
   --  ------------------------------
   procedure Append (List  : in out Select_Item_List;
                     Label : in String;
                     Value : in String) is
   begin
      List.Append (Create_Select_Item (Label, Value));
   end Append;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Select_Item_List;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

end ASF.Models.Selects;

Fix compilation warning

Fix compilation warning


-----------------------------------------------------------------------
--  awa-counters --
--  Copyright (C) 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 ADO.Objects;
with ADO.Schemas;
with Util.Strings;
with AWA.Index_Arrays;
package AWA.Counters is

   type Counter_Index_Type is new Natural;

   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   procedure Increment (Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class);

private

   type Counter_Def is record
      Table : ADO.Schemas.Class_Mapping_Access;
      Field : Util.Strings.Name_Access;
   end record;

   function "=" (Left, Right : in Counter_Def) return Boolean;
   function "<" (Left, Right : in Counter_Def) return Boolean;
   function "&" (Left  : in String;
                 Right : in Counter_Def) return String;

   package Counter_Arrays is new AWA.Index_Arrays (Counter_Index_Type, Counter_Def);

end AWA.Counters;

-----------------------------------------------------------------------
--  awa-counters --
--  Copyright (C) 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 ADO.Objects;
with ADO.Schemas;
with Util.Strings;
with AWA.Index_Arrays;
package AWA.Counters is

   type Counter_Index_Type is new Natural;

   --  Increment the counter identified by <tt>Counter</tt> and associated with the
   --  database object <tt>Object</tt>.
   procedure Increment (Counter : in Counter_Index_Type;
                        Object  : in ADO.Objects.Object_Ref'Class);

   --  Increment the global counter identified by <tt>Counter</tt>.
   procedure Increment (Counter : in Counter_Index_Type);

private

   type Counter_Def is record
      Table : ADO.Schemas.Class_Mapping_Access;
      Field : Util.Strings.Name_Access;
   end record;

   function "=" (Left, Right : in Counter_Def) return Boolean;
   function "<" (Left, Right : in Counter_Def) return Boolean;
   function "&" (Left  : in String;
                 Right : in Counter_Def) return String;

   package Counter_Arrays is new AWA.Index_Arrays (Counter_Index_Type, Counter_Def);

end AWA.Counters;

Declare Increment procedure with single Counter parameter


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

with ADO.Drivers.Connections;
package body ADO.Schemas.Databases is

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  ------------------------------
   procedure Create_Database (Session     : in out Sessions.Master_Session;
                              Config      : in Configs.Configuration'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      procedure Process (Database : in out ADO.Drivers.Connections.Database_Connection'Class);

      procedure Process (Database : in out ADO.Drivers.Connections.Database_Connection'Class) is
      begin
         Database.Create_Database (Config      => Config,
                                   Schema_Path => Schema_Path,
                                   Messages    => Messages);
      end Process;
   begin
      Session.Access_Connection (Process'Access);
   end Create_Database;

end ADO.Schemas.Databases;

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

with ADO.Drivers.Connections;
package body ADO.Schemas.Databases is

   --  ------------------------------
   --  Create the database and initialize it with the schema SQL file.
   --  ------------------------------
   procedure Create_Database (Admin       : in ADO.Sessions.Sources.Data_Source'Class;
                              Config      : in ADO.Sessions.Sources.Data_Source'Class;
                              Schema_Path : in String;
                              Messages    : out Util.Strings.Vectors.Vector) is
      Name   : constant String := Config.Get_Driver;
      Driver : constant Drivers.Connections.Driver_Access := Drivers.Connections.Get_Driver (Name);
   begin
      Messages.Clear;
      Driver.Create_Database (Admin       => Admin,
                              Config      => Config,
                              Schema_Path => Schema_Path,
                              Messages    => Messages);
   end Create_Database;

end ADO.Schemas.Databases;

Update the Create_Database operation to use the Data_Source as parameter, get the database driver and call the Create_Database on it


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

------------------------------------------------------------------------------
-- Natools.Smaz.Tools helps building and generating dictionary for use      --
-- with its parent package. Note that the dictionary is intended to be      --
-- generated and hard-coded, so the final client shouldn't need this        --
-- package.                                                                 --
------------------------------------------------------------------------------

with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Natools.S_Expressions;

private with Ada.Containers.Indefinite_Ordered_Maps;
private with Ada.Containers.Indefinite_Ordered_Sets;
private with Ada.Finalization;

package Natools.Smaz.Tools is
   pragma Preelaborate;

   package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
     (String);

   procedure Read_List
     (List : out String_Lists.List;
      Descriptor : in out S_Expressions.Descriptor'Class);
      --  Read atoms from Descriptor to fill List

   function To_Dictionary
     (List : in String_Lists.List;
      Variable_Length_Verbatim : in Boolean)
     return Dictionary
     with Pre => String_Lists.Length (List) in 1 ..
                 Ada.Containers.Count_Type (Ada.Streams.Stream_Element'Last);
      --  Build a Dictionary object from a string list
      --  Note that Hash is set to a placeholder which uncinditionnally
      --  raises Program_Error when called.

   generic
      with procedure Put_Line (Line : String);
   procedure Print_Dictionary_In_Ada
     (Dict : in Dictionary;
      Hash_Image : in String := "TODO";
      Max_Width : in Positive := 70;
      First_Prefix : in String := "     := (";
      Prefix : in String := "         ";
      Half_Indent : in String := "   ");
      --  Output Ada code corresponding to the value of the dictionary.
      --  Note that Prefix is the actual base indentation, while Half_Indent
      --  is added beyond Prefix before values continued on another line.
      --  Frist_Prefix is used instead of Prefix on the first line.
      --  All the defaults value are what was used to generate the constant
      --  in Natools.Smaz.Original.

   function Remove_Element
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return Dictionary
     with Pre => Index <= Dict.Dict_Last,
         Post => Dict.Dict_Last = Remove_Element'Result.Dict_Last + 1
               and then (Index = 0
                         or else (for all I in 0 .. Index - 1
                                  => Dict_Entry (Dict, I)
                                     = Dict_Entry (Remove_Element'Result, I)))
               and then (Index = Dict.Dict_Last
                         or else (for all I in Index .. Dict.Dict_Last - 1
                                  => Dict_Entry (Dict, I + 1)
                                     = Dict_Entry (Remove_Element'Result, I)));
      --  Return a new dictionary equal to Dict without element for Index

   function Append_String
     (Dict : in Dictionary;
      Value : in String)
     return Dictionary
     with Pre => Dict.Dict_Last < Ada.Streams.Stream_Element'Last
               and then Value'Length > 0,
         Post => Dict.Dict_Last = Append_String'Result.Dict_Last - 1
               and then (for all I in 0 .. Dict.Dict_Last
                         => Dict_Entry (Dict, I)
                            = Dict_Entry (Append_String'Result, I))
               and then Dict_Entry (Append_String'Result,
                                    Append_String'Result.Dict_Last)
                        = Value;
      --  Return a new dictionary with Value appended

   List_For_Linear_Search : String_Lists.List;
   function Linear_Search (Value : String) return Natural;
      --  Function and data source for inefficient but dynamic function
      --  that can be used with Dictionary.Hash.

   procedure Set_Dictionary_For_Map_Search (Dict : in Dictionary);
   function Map_Search (Value : String) return Natural;
      --  Function and data source for logarithmic search using standard
      --  ordered map, that can be used with Dictionary.Hash.

   type Search_Trie is private;
   procedure Initialize (Trie : out Search_Trie; Dict : in Dictionary);
   function Search (Trie : in Search_Trie; Value : in String) return Natural;
      --  Trie-based search in a dynamic dictionary, for lookup whose
      --  speed-vs-memory is even more skewed towards speed.

   procedure Set_Dictionary_For_Trie_Search (Dict : in Dictionary);
   function Trie_Search (Value : String) return Natural;
      --  Function and data source for trie-based search that can be
      --  used with Dictionary.Hash.

   type String_Count is range 0 .. 2 ** 31 - 1;
      --  Type for a number of substring occurrences

   package Methods is
      type Enum is (Encoded, Frequency, Gain);
   end Methods;
      --  Evaluation methods to select words to remove or include

   type Word_Counter is private;
      --  Accumulate frequency/occurrence counts for a set of strings

   procedure Add_Word
     (Counter : in out Word_Counter;
      Word : in String;
      Count : in String_Count := 1);
      --  Include Count number of occurrences of Word in Counter

   procedure Add_Substrings
     (Counter : in out Word_Counter;
      Phrase : in String;
      Min_Size : in Positive;
      Max_Size : in Positive);
      --  Include all the substrings of Phrase whose lengths are
      --  between Min_Size and Max_Size.

   procedure Add_Words
     (Counter : in out Word_Counter;
      Phrase : in String;
      Min_Size : in Positive;
      Max_Size : in Positive);
      --  Add the "words" from Phrase into Counter, with a word being currently
      --  defined as anything between ASCII blanks or punctuation,
      --  or in other words [0-9A-Za-z\x80-\xFF]+

   procedure Filter_By_Count
     (Counter : in out Word_Counter;
      Threshold_Count : in String_Count);
      --  Remove from Counter all entries whose count is below the threshold

   function Simple_Dictionary
     (Counter : in Word_Counter;
      Word_Count : in Natural;
      Method : in Methods.Enum := Methods.Encoded)
     return String_Lists.List;
      --  Return the Word_Count words in Counter that have the highest score,
      --  the score being count * length.

   procedure Simple_Dictionary_And_Pending
     (Counter : in Word_Counter;
      Word_Count : in Natural;
      Selected : out String_Lists.List;
      Pending : out String_Lists.List;
      Method : in Methods.Enum := Methods.Encoded;
      Max_Pending_Count : in Ada.Containers.Count_Type
        := Ada.Containers.Count_Type'Last);
      --  Return in Selected the Word_Count words in Counter that have the
      --  highest score, and in Pending the remaining words,
      --  the score being count * length.

   type Dictionary_Counts is
     array (Ada.Streams.Stream_Element) of String_Count;

   procedure Evaluate_Dictionary
     (Dict : in Dictionary;
      Corpus : in String_Lists.List;
      Compressed_Size : out Ada.Streams.Stream_Element_Count;
      Counts : out Dictionary_Counts);
   procedure Evaluate_Dictionary_Partial
     (Dict : in Dictionary;
      Corpus_Entry : in String;
      Compressed_Size : in out Ada.Streams.Stream_Element_Count;
      Counts : in out Dictionary_Counts);
      --  Compress all strings of Corpus, returning the total number of
      --  compressed bytes and the number of uses for each dictionary
      --  element.

   function Worst_Index
     (Dict : in Dictionary;
      Counts : in Dictionary_Counts;
      Method : in Methods.Enum)
     return Ada.Streams.Stream_Element;
      --  Return the element with worst score

   type Score_Value is range 0 .. 2 ** 31 - 1;

   function Length
     (Dict : in Dictionary;
      E : in Ada.Streams.Stream_Element)
     return Score_Value
     is (Natools.Smaz.Dict_Entry (Dict, E)'Length);
      --  Length of a dictionary entry

   function Score_Encoded
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Value (Counts (E)) * Length (Dict, E));
      --  Score value using the amount of encoded data using E

   function Score_Frequency
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Value (Counts (E)));
      --  Score value using the number of times E was used

   function Score_Gain
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Value (Counts (E)) * (Length (Dict, E) - 1));
      --  Score value using the number of bytes saved using E

   function Score
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : in Ada.Streams.Stream_Element;
      Method : in Methods.Enum)
     return Score_Value
     is (case Method is
         when Methods.Encoded => Score_Encoded (Dict, Counts, E),
         when Methods.Frequency => Score_Frequency (Dict, Counts, E),
         when Methods.Gain => Score_Gain (Dict, Counts, E));
      --  Scare value with dynamically chosen method

private

   package Word_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (String, String_Count);

   type Word_Counter is record
      Map : Word_Maps.Map;
   end record;

   type Scored_Word (Size : Natural) is record
      Word : String (1 .. Size);
      Score : Score_Value;
   end record;

   function "<" (Left, Right : Scored_Word) return Boolean
     is (Left.Score > Right.Score
         or else (Left.Score = Right.Score and then Left.Word < Right.Word));

   function To_Scored_Word
     (Cursor : in Word_Maps.Cursor;
      Method : in Methods.Enum)
     return Scored_Word;

   package Scored_Word_Sets is new Ada.Containers.Indefinite_Ordered_Sets
     (Scored_Word);

   package Dictionary_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (String, Ada.Streams.Stream_Element);

   Search_Map : Dictionary_Maps.Map;

   type Trie_Node;
   type Trie_Node_Access is access Trie_Node;
   type Trie_Node_Array is array (Character) of Trie_Node_Access;

   type Trie_Node (Is_Leaf : Boolean) is new Ada.Finalization.Controlled
     with record
      Index : Natural;

      case Is_Leaf is
         when True  => null;
         when False => Children : Trie_Node_Array;
      end case;
   end record;

   overriding procedure Adjust (Node : in out Trie_Node);
   overriding procedure Finalize (Node : in out Trie_Node);

   type Search_Trie is record
      Not_Found : Natural;
      Root : Trie_Node (False);
   end record;

   Trie_For_Search : Search_Trie;

end Natools.Smaz.Tools;

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

------------------------------------------------------------------------------
-- Natools.Smaz.Tools helps building and generating dictionary for use      --
-- with its parent package. Note that the dictionary is intended to be      --
-- generated and hard-coded, so the final client shouldn't need this        --
-- package.                                                                 --
------------------------------------------------------------------------------

with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Natools.S_Expressions;

private with Ada.Containers.Indefinite_Ordered_Maps;
private with Ada.Containers.Indefinite_Ordered_Sets;
private with Ada.Finalization;

package Natools.Smaz.Tools is
   pragma Preelaborate;

   package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
     (String);

   procedure Read_List
     (List : out String_Lists.List;
      Descriptor : in out S_Expressions.Descriptor'Class);
      --  Read atoms from Descriptor to fill List

   function To_Dictionary
     (List : in String_Lists.List;
      Variable_Length_Verbatim : in Boolean)
     return Dictionary
     with Pre => String_Lists.Length (List) in 1 ..
                 Ada.Containers.Count_Type (Ada.Streams.Stream_Element'Last);
      --  Build a Dictionary object from a string list
      --  Note that Hash is set to a placeholder which uncinditionnally
      --  raises Program_Error when called.

   generic
      with procedure Put_Line (Line : String);
   procedure Print_Dictionary_In_Ada
     (Dict : in Dictionary;
      Hash_Image : in String := "TODO";
      Max_Width : in Positive := 70;
      First_Prefix : in String := "     := (";
      Prefix : in String := "         ";
      Half_Indent : in String := "   ");
      --  Output Ada code corresponding to the value of the dictionary.
      --  Note that Prefix is the actual base indentation, while Half_Indent
      --  is added beyond Prefix before values continued on another line.
      --  Frist_Prefix is used instead of Prefix on the first line.
      --  All the defaults value are what was used to generate the constant
      --  in Natools.Smaz.Original.

   function Remove_Element
     (Dict : in Dictionary;
      Index : in Ada.Streams.Stream_Element)
     return Dictionary
     with Pre => Index <= Dict.Dict_Last,
         Post => Dict.Dict_Last = Remove_Element'Result.Dict_Last + 1
               and then (Index = 0
                         or else (for all I in 0 .. Index - 1
                                  => Dict_Entry (Dict, I)
                                     = Dict_Entry (Remove_Element'Result, I)))
               and then (Index = Dict.Dict_Last
                         or else (for all I in Index .. Dict.Dict_Last - 1
                                  => Dict_Entry (Dict, I + 1)
                                     = Dict_Entry (Remove_Element'Result, I)));
      --  Return a new dictionary equal to Dict without element for Index

   function Append_String
     (Dict : in Dictionary;
      Value : in String)
     return Dictionary
     with Pre => Dict.Dict_Last < Ada.Streams.Stream_Element'Last
               and then Value'Length > 0,
         Post => Dict.Dict_Last = Append_String'Result.Dict_Last - 1
               and then (for all I in 0 .. Dict.Dict_Last
                         => Dict_Entry (Dict, I)
                            = Dict_Entry (Append_String'Result, I))
               and then Dict_Entry (Append_String'Result,
                                    Append_String'Result.Dict_Last)
                        = Value;
      --  Return a new dictionary with Value appended

   List_For_Linear_Search : String_Lists.List;
   function Linear_Search (Value : String) return Natural;
      --  Function and data source for inefficient but dynamic function
      --  that can be used with Dictionary.Hash.

   procedure Set_Dictionary_For_Map_Search (Dict : in Dictionary);
   function Map_Search (Value : String) return Natural;
      --  Function and data source for logarithmic search using standard
      --  ordered map, that can be used with Dictionary.Hash.

   type Search_Trie is private;
   procedure Initialize (Trie : out Search_Trie; Dict : in Dictionary);
   function Search (Trie : in Search_Trie; Value : in String) return Natural;
      --  Trie-based search in a dynamic dictionary, for lookup whose
      --  speed-vs-memory is even more skewed towards speed.

   procedure Set_Dictionary_For_Trie_Search (Dict : in Dictionary);
   function Trie_Search (Value : String) return Natural;
      --  Function and data source for trie-based search that can be
      --  used with Dictionary.Hash.

   type String_Count is range 0 .. 2 ** 31 - 1;
      --  Type for a number of substring occurrences

   package Methods is
      type Enum is (Encoded, Frequency, Gain);
   end Methods;
      --  Evaluation methods to select words to remove or include

   type Word_Counter is private;
      --  Accumulate frequency/occurrence counts for a set of strings

   procedure Add_Word
     (Counter : in out Word_Counter;
      Word : in String;
      Count : in String_Count := 1);
      --  Include Count number of occurrences of Word in Counter

   procedure Add_Substrings
     (Counter : in out Word_Counter;
      Phrase : in String;
      Min_Size : in Positive;
      Max_Size : in Positive);
      --  Include all the substrings of Phrase whose lengths are
      --  between Min_Size and Max_Size.

   procedure Add_Words
     (Counter : in out Word_Counter;
      Phrase : in String;
      Min_Size : in Positive;
      Max_Size : in Positive);
      --  Add the "words" from Phrase into Counter, with a word being currently
      --  defined as anything between ASCII blanks or punctuation,
      --  or in other words [0-9A-Za-z\x80-\xFF]+

   procedure Filter_By_Count
     (Counter : in out Word_Counter;
      Threshold_Count : in String_Count);
      --  Remove from Counter all entries whose count is below the threshold

   function Simple_Dictionary
     (Counter : in Word_Counter;
      Word_Count : in Natural;
      Method : in Methods.Enum := Methods.Encoded)
     return String_Lists.List;
      --  Return the Word_Count words in Counter that have the highest score,
      --  the score being count * length.

   procedure Simple_Dictionary_And_Pending
     (Counter : in Word_Counter;
      Word_Count : in Natural;
      Selected : out String_Lists.List;
      Pending : out String_Lists.List;
      Method : in Methods.Enum := Methods.Encoded;
      Max_Pending_Count : in Ada.Containers.Count_Type
        := Ada.Containers.Count_Type'Last);
      --  Return in Selected the Word_Count words in Counter that have the
      --  highest score, and in Pending the remaining words,
      --  the score being count * length.

   type Dictionary_Counts is
     array (Ada.Streams.Stream_Element) of String_Count;

   procedure Evaluate_Dictionary
     (Dict : in Dictionary;
      Corpus : in String_Lists.List;
      Compressed_Size : out Ada.Streams.Stream_Element_Count;
      Counts : out Dictionary_Counts);
   procedure Evaluate_Dictionary_Partial
     (Dict : in Dictionary;
      Corpus_Entry : in String;
      Compressed_Size : in out Ada.Streams.Stream_Element_Count;
      Counts : in out Dictionary_Counts);
      --  Compress all strings of Corpus, returning the total number of
      --  compressed bytes and the number of uses for each dictionary
      --  element.

   function Worst_Index
     (Dict : in Dictionary;
      Counts : in Dictionary_Counts;
      Method : in Methods.Enum)
     return Ada.Streams.Stream_Element;
      --  Return the element with worst score

   type Score_Value is range 0 .. 2 ** 31 - 1;

   function Score_Encoded
     (Count : in String_Count; Length : in Positive) return Score_Value
     is (Score_Value (Count) * Score_Value (Length));
      --  Score value using the amount of encoded data by the element

   function Score_Frequency
     (Count : in String_Count; Length : in Positive) return Score_Value
     is (Score_Value (Count));
      --  Score value using the number of times the element was used

   function Score_Gain
     (Count : in String_Count; Length : in Positive) return Score_Value
     is (Score_Value (Count) * (Score_Value (Length) - 1));
      --  Score value using the number of bytes saved using the element

   function Score
     (Count : in String_Count;
      Length : in Positive;
      Method : in Methods.Enum)
     return Score_Value
     is (case Method is
         when Methods.Encoded => Score_Encoded (Count, Length),
         when Methods.Frequency => Score_Frequency (Count, Length),
         when Methods.Gain => Score_Gain (Count, Length));
      --  Scare value with dynamically chosen method

   function Length
     (Dict : in Dictionary;
      E : in Ada.Streams.Stream_Element)
     return Positive
     is (Natools.Smaz.Dict_Entry (Dict, E)'Length);
      --  Length of a dictionary entry

   function Score_Encoded
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Encoded (Counts (E), Length (Dict, E)));
      --  Score value using the amount of encoded data using E

   function Score_Frequency
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Frequency (Counts (E), Length (Dict, E)));
      --  Score value using the number of times E was used

   function Score_Gain
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : Ada.Streams.Stream_Element)
     return Score_Value
     is (Score_Gain (Counts (E), Length (Dict, E)));
      --  Score value using the number of bytes saved using E

   function Score
     (Dict : in Dictionary;
      Counts : in Natools.Smaz.Tools.Dictionary_Counts;
      E : in Ada.Streams.Stream_Element;
      Method : in Methods.Enum)
     return Score_Value
     is (Score (Counts (E), Length (Dict, E), Method));
      --  Scare value with dynamically chosen method

private

   package Word_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (String, String_Count);

   type Word_Counter is record
      Map : Word_Maps.Map;
   end record;

   type Scored_Word (Size : Natural) is record
      Word : String (1 .. Size);
      Score : Score_Value;
   end record;

   function "<" (Left, Right : Scored_Word) return Boolean
     is (Left.Score > Right.Score
         or else (Left.Score = Right.Score and then Left.Word < Right.Word));

   function To_Scored_Word
     (Cursor : in Word_Maps.Cursor;
      Method : in Methods.Enum)
     return Scored_Word;

   package Scored_Word_Sets is new Ada.Containers.Indefinite_Ordered_Sets
     (Scored_Word);

   package Dictionary_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (String, Ada.Streams.Stream_Element);

   Search_Map : Dictionary_Maps.Map;

   type Trie_Node;
   type Trie_Node_Access is access Trie_Node;
   type Trie_Node_Array is array (Character) of Trie_Node_Access;

   type Trie_Node (Is_Leaf : Boolean) is new Ada.Finalization.Controlled
     with record
      Index : Natural;

      case Is_Leaf is
         when True  => null;
         when False => Children : Trie_Node_Array;
      end case;
   end record;

   overriding procedure Adjust (Node : in out Trie_Node);
   overriding procedure Finalize (Node : in out Trie_Node);

   type Search_Trie is record
      Not_Found : Natural;
      Root : Trie_Node (False);
   end record;

   Trie_For_Search : Search_Trie;

end Natools.Smaz.Tools;

smaz-tools: add dictionary-independent scoring functions


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

with Util.Beans.Basic;
with Util.Locales;

with EL.Objects;
with EL.Contexts;
with EL.Functions;
with EL.Functions.Default;
with EL.Expressions;
with EL.Variables.Default;
with Ada.Strings.Unbounded;

with ASF.Locales;
with ASF.Factory;
with ASF.Converters;
with ASF.Validators;
with ASF.Contexts.Faces;
with ASF.Contexts.Exceptions;
with ASF.Lifecycles;
with ASF.Applications.Views;
with ASF.Navigations;
with ASF.Beans;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Events.Faces.Actions;
with Security.Policies;  use Security;
with Security.OAuth.Servers;

package ASF.Applications.Main is

   use ASF.Beans;

   --  ------------------------------
   --  Factory for creation of lifecycle, view handler
   --  ------------------------------
   type Application_Factory is tagged limited private;

   --  Create the lifecycle handler.  The lifecycle handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Lifecycles.Default.Default_Lifecycle object.
   --  It can be overriden to change the behavior of the ASF request lifecycle.
   function Create_Lifecycle_Handler (App : in Application_Factory)
                                      return ASF.Lifecycles.Lifecycle_Access;

   --  Create the view handler.  The view handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Applications.Views.View_Handler object.
   --  It can be overriden to change the views associated with the application.
   function Create_View_Handler (App : in Application_Factory)
                                 return ASF.Applications.Views.View_Handler_Access;

   --  Create the navigation handler.  The navigation handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Navigations.Navigation_Handler object.
   --  It can be overriden to change the navigations associated with the application.
   function Create_Navigation_Handler (App : in Application_Factory)
                                       return ASF.Navigations.Navigation_Handler_Access;

   --  Create the security policy manager.  The security policy manager is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a Security.Policies.Policy_Manager object.
   function Create_Security_Manager (App : in Application_Factory)
                                       return Security.Policies.Policy_Manager_Access;

   --  Create the OAuth application manager.  The OAuth application manager is created
   --  during the initialization phase of the application.  The default implementation
   --  creates a Security.OAuth.Servers.Auth_Manager object.
   function Create_OAuth_Manager (App : in Application_Factory)
                                  return Security.OAuth.Servers.Auth_Manager_Access;

   --  Create the exception handler.  The exception handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a ASF.Contexts.Exceptions.Exception_Handler object.
   function Create_Exception_Handler (App : in Application_Factory)
                                      return ASF.Contexts.Exceptions.Exception_Handler_Access;

   --  ------------------------------
   --  Application
   --  ------------------------------
   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with private;
   type Application_Access is access all Application'Class;

   --  Get the application view handler.
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class;

   --  Get the lifecycle handler.
   function Get_Lifecycle_Handler (App : in Application)
                                   return ASF.Lifecycles.Lifecycle_Access;

   --  Get the navigation handler.
   function Get_Navigation_Handler (App : in Application)
                                    return ASF.Navigations.Navigation_Handler_Access;

   --  Get the permission manager associated with this application.
   function Get_Security_Manager (App : in Application)
                                    return Security.Policies.Policy_Manager_Access;

   --  Get the OAuth application manager associated with this application.
   function Get_OAuth_Manager (App : in Application)
                               return Security.OAuth.Servers.Auth_Manager_Access;

   --  Get the action event listener responsible for processing action
   --  events and triggering the navigation to the next view using the
   --  navigation handler.
   function Get_Action_Listener (App : in Application)
                                 return ASF.Events.Faces.Actions.Action_Listener_Access;

   --  Process the action associated with the action event.  The action returns
   --  and outcome which is then passed to the navigation handler to navigate to
   --  the next view.
   overriding
   procedure Process_Action (Listener : in Application;
                             Event    : in ASF.Events.Faces.Actions.Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Execute the action method.  The action returns and outcome which is then passed
   --  to the navigation handler to navigate to the next view.
   procedure Process_Action (Listener : in Application;
                             Method   : in EL.Expressions.Method_Info;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Initialize the application
   procedure Initialize (App     : in out Application;
                         Conf    : in Config;
                         Factory : in out Application_Factory'Class);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   procedure Initialize_Components (App : in out Application);

   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out Config);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   procedure Initialize_Filters (App : in out Application);

   --  Finalizes the application, freeing the memory.
   overriding
   procedure Finalize (App : in out Application);

   --  Get the configuration parameter;
   function Get_Config (App   : Application;
                        Param : Config_Param) return String;

   --  Set a global variable in the global EL contexts.
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String);

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object);

   --  Resolve a global variable and return its value.
   --  Raises the EL.Functions.No_Variable exception if the variable does not exist.
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (App : in Application)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (App    : in out Application;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (App : in Application) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (App    : in out Application;
                                 Locale : in Util.Locales.Locale);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Handler : in Application;
                              Context : in ASF.Contexts.Faces.Faces_Context'Class)
                              return Util.Locales.Locale;

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String);

   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE);

   --  Register under the name identified by Name the class instance Class.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Class   : in ASF.Beans.Class_Binding_Access);

   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Handler : in ASF.Beans.Create_Bean_Access);

   --  Create a bean by using the create operation registered for the name
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type);

   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : in ASF.Converters.Converter_Access);

   --  Register a binding library in the factory.
   procedure Add_Components (App      : in out Application;
                             Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Closes the application
   procedure Close (App : in out Application);

   --  Set the current faces context before processing a view.
   procedure Set_Context (App     : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access);

   --  Execute the lifecycle phases on the faces context.
   procedure Execute_Lifecycle (App     : in Application;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Dispatch the request received on a page.
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Dispatch a bean action request.
   --  1. Find the bean object identified by Name, create it if necessary.
   --  2. Resolve the bean method identified by Operation.
   --  3. If the method is an action method (see ASF.Events.Actions), call that method.
   --  4. Using the outcome action result, decide using the navigation handler what
   --     is the result view.
   --  5. Render the result view resolved by the navigation handler.
   procedure Dispatch (App       : in out Application;
                       Name      : in String;
                       Operation : in String;
                       Request   : in out ASF.Requests.Request'Class;
                       Response  : in out ASF.Responses.Response'Class;
                       Prepare   : access procedure (Bean : access Util.Beans.Basic.Bean'Class));

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find_Validator (App  : in Application;
                            Name : in EL.Objects.Object)
                            return ASF.Validators.Validator_Access;

   --  Register some functions
   generic
      with procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   procedure Register_Functions (App : in out Application'Class);

   --  Register some bean definitions.
   generic
      with procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
   procedure Register_Beans (App : in out Application'Class);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (App    : in out Application;
                          Name   : in String;
                          Locale : in String;
                          Bundle : out ASF.Locales.Bundle);

private

   type Application_Factory is tagged limited null record;

   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with record
      View    : aliased ASF.Applications.Views.View_Handler;
      Lifecycle : ASF.Lifecycles.Lifecycle_Access;
      Factory : aliased ASF.Beans.Bean_Factory;
      Locales : ASF.Locales.Factory;
      Globals : aliased EL.Variables.Default.Default_Variable_Mapper;

      Functions : aliased EL.Functions.Default.Default_Function_Mapper;

      --  The component factory
      Components : aliased ASF.Factory.Component_Factory;

      --  The action listener.
      Action_Listener : ASF.Events.Faces.Actions.Action_Listener_Access;

      --  The navigation handler.
      Navigation      : ASF.Navigations.Navigation_Handler_Access;

      --  The permission manager.
      Permissions     : Security.Policies.Policy_Manager_Access;

      --  The OAuth application manager.
      OAuth           : Security.OAuth.Servers.Auth_Manager_Access;

      --  Exception handler
      Exceptions      : ASF.Contexts.Exceptions.Exception_Handler_Access;
   end record;

end ASF.Applications.Main;

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

with Util.Beans.Basic;
with Util.Locales;

with EL.Objects;
with EL.Contexts;
with EL.Functions;
with EL.Functions.Default;
with EL.Expressions;
with EL.Variables.Default;
with Ada.Strings.Unbounded;

with ASF.Locales;
with ASF.Factory;
with ASF.Converters;
with ASF.Validators;
with ASF.Contexts.Faces;
with ASF.Contexts.Exceptions;
with ASF.Lifecycles;
with ASF.Applications.Views;
with ASF.Navigations;
with ASF.Beans;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Events.Faces.Actions;
with Security.Policies;  use Security;
with Security.OAuth.Servers;

package ASF.Applications.Main is

   use ASF.Beans;

   --  ------------------------------
   --  Factory for creation of lifecycle, view handler
   --  ------------------------------
   type Application_Factory is tagged limited private;

   --  Create the lifecycle handler.  The lifecycle handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Lifecycles.Default.Default_Lifecycle object.
   --  It can be overriden to change the behavior of the ASF request lifecycle.
   function Create_Lifecycle_Handler (App : in Application_Factory)
                                      return ASF.Lifecycles.Lifecycle_Access;

   --  Create the view handler.  The view handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Applications.Views.View_Handler object.
   --  It can be overriden to change the views associated with the application.
   function Create_View_Handler (App : in Application_Factory)
                                 return ASF.Applications.Views.View_Handler_Access;

   --  Create the navigation handler.  The navigation handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Navigations.Navigation_Handler object.
   --  It can be overriden to change the navigations associated with the application.
   function Create_Navigation_Handler (App : in Application_Factory)
                                       return ASF.Navigations.Navigation_Handler_Access;

   --  Create the security policy manager.  The security policy manager is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a Security.Policies.Policy_Manager object.
   function Create_Security_Manager (App : in Application_Factory)
                                       return Security.Policies.Policy_Manager_Access;

   --  Create the OAuth application manager.  The OAuth application manager is created
   --  during the initialization phase of the application.  The default implementation
   --  creates a Security.OAuth.Servers.Auth_Manager object.
   function Create_OAuth_Manager (App : in Application_Factory)
                                  return Security.OAuth.Servers.Auth_Manager_Access;

   --  Create the exception handler.  The exception handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a ASF.Contexts.Exceptions.Exception_Handler object.
   function Create_Exception_Handler (App : in Application_Factory)
                                      return ASF.Contexts.Exceptions.Exception_Handler_Access;

   --  ------------------------------
   --  Application
   --  ------------------------------
   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with private;
   type Application_Access is access all Application'Class;

   --  Get the application view handler.
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class;

   --  Get the lifecycle handler.
   function Get_Lifecycle_Handler (App : in Application)
                                   return ASF.Lifecycles.Lifecycle_Access;

   --  Get the navigation handler.
   function Get_Navigation_Handler (App : in Application)
                                    return ASF.Navigations.Navigation_Handler_Access;

   --  Get the permission manager associated with this application.
   function Get_Security_Manager (App : in Application)
                                    return Security.Policies.Policy_Manager_Access;

   --  Get the OAuth application manager associated with this application.
   function Get_OAuth_Manager (App : in Application)
                               return Security.OAuth.Servers.Auth_Manager_Access;

   --  Get the action event listener responsible for processing action
   --  events and triggering the navigation to the next view using the
   --  navigation handler.
   function Get_Action_Listener (App : in Application)
                                 return ASF.Events.Faces.Actions.Action_Listener_Access;

   --  Get the exception handler configured for this application.
   function Get_Exception_Handler (App : in Application)
                               return ASF.Contexts.Exceptions.Exception_Handler_Access;

   --  Process the action associated with the action event.  The action returns
   --  and outcome which is then passed to the navigation handler to navigate to
   --  the next view.
   overriding
   procedure Process_Action (Listener : in Application;
                             Event    : in ASF.Events.Faces.Actions.Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Execute the action method.  The action returns and outcome which is then passed
   --  to the navigation handler to navigate to the next view.
   procedure Process_Action (Listener : in Application;
                             Method   : in EL.Expressions.Method_Info;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Initialize the application
   procedure Initialize (App     : in out Application;
                         Conf    : in Config;
                         Factory : in out Application_Factory'Class);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   procedure Initialize_Components (App : in out Application);

   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out Config);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   procedure Initialize_Filters (App : in out Application);

   --  Finalizes the application, freeing the memory.
   overriding
   procedure Finalize (App : in out Application);

   --  Get the configuration parameter;
   function Get_Config (App   : Application;
                        Param : Config_Param) return String;

   --  Set a global variable in the global EL contexts.
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String);

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object);

   --  Resolve a global variable and return its value.
   --  Raises the EL.Functions.No_Variable exception if the variable does not exist.
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (App : in Application)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (App    : in out Application;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (App : in Application) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (App    : in out Application;
                                 Locale : in Util.Locales.Locale);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Handler : in Application;
                              Context : in ASF.Contexts.Faces.Faces_Context'Class)
                              return Util.Locales.Locale;

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String);

   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE);

   --  Register under the name identified by Name the class instance Class.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Class   : in ASF.Beans.Class_Binding_Access);

   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Handler : in ASF.Beans.Create_Bean_Access);

   --  Create a bean by using the create operation registered for the name
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type);

   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : in ASF.Converters.Converter_Access);

   --  Register a binding library in the factory.
   procedure Add_Components (App      : in out Application;
                             Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Closes the application
   procedure Close (App : in out Application);

   --  Set the current faces context before processing a view.
   procedure Set_Context (App     : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access);

   --  Execute the lifecycle phases on the faces context.
   procedure Execute_Lifecycle (App     : in Application;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Dispatch the request received on a page.
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Dispatch a bean action request.
   --  1. Find the bean object identified by Name, create it if necessary.
   --  2. Resolve the bean method identified by Operation.
   --  3. If the method is an action method (see ASF.Events.Actions), call that method.
   --  4. Using the outcome action result, decide using the navigation handler what
   --     is the result view.
   --  5. Render the result view resolved by the navigation handler.
   procedure Dispatch (App       : in out Application;
                       Name      : in String;
                       Operation : in String;
                       Request   : in out ASF.Requests.Request'Class;
                       Response  : in out ASF.Responses.Response'Class;
                       Prepare   : access procedure (Bean : access Util.Beans.Basic.Bean'Class));

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find_Validator (App  : in Application;
                            Name : in EL.Objects.Object)
                            return ASF.Validators.Validator_Access;

   --  Register some functions
   generic
      with procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   procedure Register_Functions (App : in out Application'Class);

   --  Register some bean definitions.
   generic
      with procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
   procedure Register_Beans (App : in out Application'Class);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (App    : in out Application;
                          Name   : in String;
                          Locale : in String;
                          Bundle : out ASF.Locales.Bundle);

private

   type Application_Factory is tagged limited null record;

   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with record
      View    : aliased ASF.Applications.Views.View_Handler;
      Lifecycle : ASF.Lifecycles.Lifecycle_Access;
      Factory : aliased ASF.Beans.Bean_Factory;
      Locales : ASF.Locales.Factory;
      Globals : aliased EL.Variables.Default.Default_Variable_Mapper;

      Functions : aliased EL.Functions.Default.Default_Function_Mapper;

      --  The component factory
      Components : aliased ASF.Factory.Component_Factory;

      --  The action listener.
      Action_Listener : ASF.Events.Faces.Actions.Action_Listener_Access;

      --  The navigation handler.
      Navigation      : ASF.Navigations.Navigation_Handler_Access;

      --  The permission manager.
      Permissions     : Security.Policies.Policy_Manager_Access;

      --  The OAuth application manager.
      OAuth           : Security.OAuth.Servers.Auth_Manager_Access;

      --  Exception handler
      Exceptions      : ASF.Contexts.Exceptions.Exception_Handler_Access;
   end record;

end ASF.Applications.Main;

Declare the Get_Exception_Handler function


-- t0026.adb - Sat Jan 11 23:18:41 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- Protected under the following license:
-- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999

with Ada.Text_IO;

with Posix;
use Posix;

procedure T0026 is
   use Ada.Text_IO;

   Child :     pid_t := -1;
   Resource :  s_rusage;
   Status :    int_t := 0;
   Error :     errno_t;
   pragma Volatile(Error);
begin

   Put_Line("Test 0026 - Wait3");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child = 0 then
      -- Child fork
      for Count in Natural(0)..10000000 loop
         Error := 0;
      end loop;

      Sys_Exit(42);
   end if;

   Wait3(Child,0,Status,Resource,Error);
   pragma Assert(Error = 0);
   pragma Assert(WIFEXITED(Status));
   pragma Assert(WEXITSTATUS(Status) = 42);
   pragma Assert(Resource.ru_utime.tv_usec > 0);
   pragma Assert(Resource.ru_stime.tv_usec > 0);

   Put_Line("Test 0026 Passed.");

end T0026;

-- t0026.adb - Sat Jan 11 23:18:41 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- Protected under the following license:
-- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999

with Ada.Text_IO;

with Posix;
use Posix;

procedure T0026 is
   use Ada.Text_IO;

   Child :     pid_t := -1;
   Resource :  s_rusage;
   Status :    int_t := 0;
   Error :     errno_t;
   pragma Volatile(Error);
begin

   Put_Line("Test 0026 - Wait3");

   Fork(Child,Error);
   pragma Assert(Error = 0);

   if Child = 0 then
      -- Child fork
      for Count in Natural(0)..10000000 loop
         Error := 0;
      end loop;

      Sys_Exit(42);
   end if;

   Wait3(Child,0,Status,Resource,Error);
   pragma Assert(Error = 0);
   pragma Assert(WIFEXITED(Status));
   pragma Assert(WEXITSTATUS(Status) = 42);
   pragma Assert(Resource.ru_utime.tv_usec > 0);
   pragma Assert(Resource.ru_stime.tv_usec >= 0);

   Put_Line("Test 0026 Passed.");

end T0026;

Fix applied for Linux resource usage

Fix applied for Linux resource usage