-----------------------------------------------------------------------
--  security-controllers-roles -- Simple role base security
--  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 Util.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

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

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

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

-----------------------------------------------------------------------
--  security-controllers-roles -- Simple role base security
--  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 Util.Serialize.Mappers.Record_Mapper;
package body Security.Controllers.Roles is

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

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

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Permissions.Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------
   package body Reader_Config is
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Manager;
      Config_Mapper.Set_Context (Reader, Config'Unchecked_Access);
   end Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Controllers.Roles;

Add permission parameter

Add permission parameter


-----------------------------------------------------------------------
--  gen-artifacts-query -- Query artifact for Code Generator
--  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 Ada.Strings.Unbounded;
with Ada.Directories;

with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Util.Log.Loggers;
with Util.Encoders.HMAC.SHA1;

--  The Gen.Artifacts.Query package is an artifact for the generation of
--  data structures returned by queries.
package body Gen.Artifacts.Query is

   use Ada.Strings.Unbounded;
   use Gen.Model;
   use Gen.Model.Tables;
   use Gen.Model.Queries;

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   procedure Initialize (Handler : in Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is
      pragma Unreferenced (Handler);

      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node);

      procedure Register_Columns (Table : in out Query_Definition);

      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node);

      Hash : Unbounded_String;

      --  ------------------------------
      --  Register the column definition in the table
      --  ------------------------------
      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Model.Get_Attribute (Column, "name");
         C     : constant Column_Definition_Access := new Column_Definition;
      begin
         C.Node := Column;
         C.Number := Table.Members.Get_Count;
         Table.Members.Append (C);

         C.Type_Name := To_Unbounded_String (Get_Normalized_Type (Column, "type"));

         C.Is_Inserted := False;
         C.Is_Updated  := False;
         C.Not_Null    := False;
         C.Unique      := False;

         --  Construct the hash for this column mapping.
         Append (Hash, ",type=");
         Append (Hash, C.Type_Name);
         Append (Hash, ",name=");
         Append (Hash, Name);
      end Register_Column;

      --  ------------------------------
      --  Register all the columns defined in the table
      --  ------------------------------
      procedure Register_Columns (Table : in out Query_Definition) is
         procedure Iterate is new Gen.Utils.Iterate_Nodes (T       => Query_Definition,
                                                           Process => Register_Column);
      begin
         Log.Debug ("Register columns from query {0}", Table.Name);

         Iterate (Table, Table.Node, "property");
      end Register_Columns;

      --  ------------------------------
      --  Register a new class definition in the model.
      --  ------------------------------
      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Model.Get_Attribute (Node, "name");
      begin
         Query.Node := Node;
         Query.Set_Table_Name (Query.Get_Attribute ("name"));

         if Name /= "" then
            Query.Name := Name;
         else
            Query.Name := To_Unbounded_String (Gen.Utils.Get_Query_Name (Path));
         end if;

         --  Construct the hash for this column mapping.
         Append (Hash, "class=");
         Append (Hash, Query.Name);

         Log.Debug ("Register query {0} with type {0}", Query.Name, Query.Type_Name);
         Register_Columns (Query);
      end Register_Mapping;

      --  ------------------------------
      --  Register a new query.
      --  ------------------------------
      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node) is
         C    : constant Column_Definition_Access := new Column_Definition;
      begin
         C.Node := Node;
         C.Number := Query.Queries.Get_Count;
         Query.Queries.Append (C);
      end Register_Query;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate_Mapping is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Mapping);
         procedure Iterate_Query is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Query);

         Table : constant Query_Definition_Access := new Query_Definition;
         Pkg   : constant Unbounded_String := Gen.Model.Get_Attribute (Node, "package");
      begin
         Table.File_Name := To_Unbounded_String (Ada.Directories.Simple_Name (Path));
         Table.Pkg_Name  := Pkg;
         Iterate_Mapping (Query_Definition (Table.all), Node, "class");
         Iterate_Query (Query_Definition (Table.all), Node, "query");
         if Length (Table.Pkg_Name) = 0 then
            Context.Error ("Missing or empty package attribute");
         else
            Model.Register_Query (Table);
         end if;

         Log.Info ("Query hash for {0} is {1}", Path, To_String (Hash));
         Table.Sha1 := Util.Encoders.HMAC.SHA1.Sign (Key  => "ADO.Queries",
                                                     Data => To_String (Hash));
      end Register_Mapping;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mapping);

   begin
      Log.Debug ("Initializing query artifact for the configuration");

      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "query-mapping");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (Handler : in Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Debug ("Preparing the model for query");

      if Model.Has_Packages then
         Context.Add_Generation (Name => GEN_PACKAGE_SPEC, Mode => ITERATION_PACKAGE);
         Context.Add_Generation (Name => GEN_PACKAGE_BODY, Mode => ITERATION_PACKAGE);
      end if;
   end Prepare;

end Gen.Artifacts.Query;

-----------------------------------------------------------------------
--  gen-artifacts-query -- Query artifact for Code Generator
--  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 Ada.Strings.Unbounded;
with Ada.Directories;

with Gen.Utils;
with Gen.Model.Tables;
with Gen.Model.Queries;
with Util.Log.Loggers;
with Util.Encoders.HMAC.SHA1;

--  The Gen.Artifacts.Query package is an artifact for the generation of
--  data structures returned by queries.
package body Gen.Artifacts.Query is

   use Ada.Strings.Unbounded;
   use Gen.Model;
   use Gen.Model.Tables;
   use Gen.Model.Queries;

   use type DOM.Core.Node;
   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Artifacts.Query");

   --  ------------------------------
   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   --  ------------------------------
   procedure Initialize (Handler : in Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class) is
      pragma Unreferenced (Handler);

      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node);

      procedure Register_Columns (Table : in out Query_Definition);

      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node);

      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node);

      Hash : Unbounded_String;

      --  ------------------------------
      --  Register the column definition in the table
      --  ------------------------------
      procedure Register_Column (Table  : in out Query_Definition;
                                 Column : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Model.Get_Attribute (Column, "name");
         C     : constant Column_Definition_Access := new Column_Definition;
      begin
         C.Node := Column;
         C.Number := Table.Members.Get_Count;
         Table.Members.Append (C);

         C.Type_Name := To_Unbounded_String (Get_Normalized_Type (Column, "type"));

         C.Is_Inserted := False;
         C.Is_Updated  := False;
         C.Not_Null    := False;
         C.Unique      := False;

         --  Construct the hash for this column mapping.
         Append (Hash, ",type=");
         Append (Hash, C.Type_Name);
         Append (Hash, ",name=");
         Append (Hash, Name);
      end Register_Column;

      --  ------------------------------
      --  Register all the columns defined in the table
      --  ------------------------------
      procedure Register_Columns (Table : in out Query_Definition) is
         procedure Iterate is new Gen.Utils.Iterate_Nodes (T       => Query_Definition,
                                                           Process => Register_Column);
      begin
         Log.Debug ("Register columns from query {0}", Table.Name);

         Iterate (Table, Table.Node, "property");
      end Register_Columns;

      --  ------------------------------
      --  Register a new class definition in the model.
      --  ------------------------------
      procedure Register_Mapping (Query : in out Gen.Model.Queries.Query_Definition;
                                  Node  : in DOM.Core.Node) is
         Name  : constant Unbounded_String := Gen.Model.Get_Attribute (Node, "name");
      begin
         Query.Node := Node;
         Query.Set_Table_Name (Query.Get_Attribute ("name"));

         if Name /= "" then
            Query.Name := Name;
         else
            Query.Name := To_Unbounded_String (Gen.Utils.Get_Query_Name (Path));
         end if;

         --  Construct the hash for this column mapping.
         Append (Hash, "class=");
         Append (Hash, Query.Name);

         Log.Debug ("Register query {0} with type {0}", Query.Name, Query.Type_Name);
         Register_Columns (Query);
      end Register_Mapping;

      --  ------------------------------
      --  Register a new query.
      --  ------------------------------
      procedure Register_Query (Query : in out Gen.Model.Queries.Query_Definition;
                                Node  : in DOM.Core.Node) is
         C    : constant Column_Definition_Access := new Column_Definition;
      begin
         C.Node := Node;
         C.Number := Query.Queries.Get_Count;
         Query.Queries.Append (C);
      end Register_Query;

      --  ------------------------------
      --  Register a model mapping
      --  ------------------------------
      procedure Register_Mapping (Model : in out Gen.Model.Packages.Model_Definition;
                                  Node  : in DOM.Core.Node) is
         procedure Iterate_Mapping is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Mapping);
         procedure Iterate_Query is
           new Gen.Utils.Iterate_Nodes (T => Gen.Model.Queries.Query_Definition,
                                        Process => Register_Query);

         Table : constant Query_Definition_Access := new Query_Definition;
         Pkg   : constant Unbounded_String := Gen.Model.Get_Attribute (Node, "package");
      begin
         Table.File_Name := To_Unbounded_String (Ada.Directories.Simple_Name (Path));
         Table.Pkg_Name  := Pkg;
         Table.Node      := Node;
         Iterate_Mapping (Query_Definition (Table.all), Node, "class");
         Iterate_Query (Query_Definition (Table.all), Node, "query");
         if Length (Table.Pkg_Name) = 0 then
            Context.Error ("Missing or empty package attribute");
         else
            Model.Register_Query (Table);
         end if;

         Log.Info ("Query hash for {0} is {1}", Path, To_String (Hash));
         Table.Sha1 := Util.Encoders.HMAC.SHA1.Sign (Key  => "ADO.Queries",
                                                     Data => To_String (Hash));
      end Register_Mapping;

      procedure Iterate is new Gen.Utils.Iterate_Nodes (T => Gen.Model.Packages.Model_Definition,
                                                        Process => Register_Mapping);

   begin
      Log.Debug ("Initializing query artifact for the configuration");

      Iterate (Gen.Model.Packages.Model_Definition (Model), Node, "query-mapping");
   end Initialize;

   --  ------------------------------
   --  Prepare the generation of the package:
   --  o identify the column types which are used
   --  o build a list of package for the with clauses.
   --  ------------------------------
   overriding
   procedure Prepare (Handler : in Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Debug ("Preparing the model for query");

      if Model.Has_Packages then
         Context.Add_Generation (Name => GEN_PACKAGE_SPEC, Mode => ITERATION_PACKAGE);
         Context.Add_Generation (Name => GEN_PACKAGE_BODY, Mode => ITERATION_PACKAGE);
      end if;
   end Prepare;

end Gen.Artifacts.Query;

Fix crash when an XML query does not specify a class mapping


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

package Mysql is

end Mysql;

-----------------------------------------------------------------------
--  ADO Mysql -- Mysql Interface
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

package Mysql is
   pragma Pure;
end Mysql;

Make the package Pure

Make the package Pure


-- Functions_Example
-- A example of using the Ada 2012 interface to Lua for functions / closures etc

-- Copyright (c) 2015, James Humphry - see LICENSE.md for terms

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Long_Float_Text_IO; use Ada.Long_Float_Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Characters.Latin_1;

with Lua; use Lua;
with Lua.Libs;
with Lua.Util; use Lua.Util;

with Example_AdaFunctions;

procedure Functions_Example is
   L : Lua_State;
   Success : Thread_Status;
   R : Lua_Reference;

   LF : Character renames Ada.Characters.Latin_1.LF;
   Coroutine_Source : String := "" &
     "function co (x) " & LF &
     " for i = 1, x do " & LF &
     "  yield(i) " & LF &
     " end " & LF &
     " return -1 " & LF &
     " end " & LF &
     "";

begin

   Put_Line("A simple example of using Lua and Ada functions together");

   Put("Lua version: ");
   Put(Item => L.Version, Aft => 0, Exp => 0);
   New_Line; New_Line;

   Put_Line("Loading chunk: function f (x) return 2*x end");
   Success := L.LoadString("function f (x) return 2*x end");
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   L.Call(0, 0);
   Put_Line("Compiled chunk.");
   Put("Result of calling f (3): ");
   L.PushInteger(3);
   L.Call_Function(name => "f", nargs => 1, nresults => 1);
   Put(L.ToNumber(-1), Aft => 0, Exp => 0); New_Line;
   New_Line;

   Put_Line("Saving a reference to the top of the stack and clearing it.");
   R := Ref(L);
   L.Pop(L.GetTop);
   Print_Stack(L);
   Put_Line("Retrieving reference...");
   L.Get(R);
   Print_Stack(L);
   New_Line;

   Put_Line("Loading IO library and running example Lua file");
   Libs.Require_Standard_Library(L, LIbs.IO_Lib);
   Success := L.LoadFile("examples/example_lua.lua");
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   if Success = OK then
      L.Call(0, 0);
      Put_Line("Compiled chunk. Result of calling triangle (5):");
      L.PushNumber(5.0);
      L.Call_Function(name => "triangle", nargs => 1, nresults => 0);
   end if;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction foobar in Lua");
   L.Register("foobar", AdaFunction'(Example_AdaFunctions.Foobar'Access));
   Success := L.LoadString("baz = foobar(5.0)");
   Put_Line("Loading code snippet 'baz = foobar(5.0)'" &
            (if Success /= OK then " not" else "") & " successful.");
   Put_Line("Calling 'baz = foobar(5.0)' from Lua");
   L.Call(0, 0);
   Put("baz = ");
   L.GetGlobal("baz");
   Put(L.ToNumber(-1), Aft => 0, Exp => 0); New_Line;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Checking foobar can be retrieved");
   L.GetGlobal("foobar");
   if not L.IsAdaFunction(-1) then
      Put_Line("Error - foobar does not contain an AdaFunction?");
   end if;
   if L.ToAdaFunction(-1) = AdaFunction'(Example_AdaFunctions.Foobar'Access) then
      Put_Line("AdaFunction foobar retrieved successfully from Lua");
   else
      Put_Line("AdaFunction foobar was NOT retrieved from Lua");
   end if;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction multret in Lua");
   L.Register("multret", AdaFunction'(Example_AdaFunctions.Multret'Access));
   Put_Line("Calling 'multret(5)' from Lua");
   L.PushInteger(5);
   L.Call_Function(name => "multret", nargs => 1, nresults => MultRet_Sentinel);
   Print_Stack(L);
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction closure (with upvalue 2.0) in Lua");
   L.PushNumber(2.0);
   L.PushAdaClosure(AdaFunction'(Example_AdaFunctions.Closure'Access), 1);
   L.SetGlobal("closure");
   Put_Line("Calling 'closure(3.5)' from Lua");
   L.PushNumber(3.5);
   L.Call_Function(name => "closure", nargs => 1, nresults => MultRet_Sentinel);
   Print_Stack(L);
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Now to look at using coroutines");
   Libs.Add_Yield_Function(L);
   Put_Line("Loading coroutine source: ");
   Put_Line(Coroutine_Source);
   Success := L.LoadString(Coroutine_Source);
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   L.Call(0, 0);
   Put_Line("Compiled coroutine code.");
   declare
      Coroutine : Lua_Thread := L.NewThread;
      Coroutine_Status : Thread_Status;
   begin
      Put_Line("New thread created");
      Put_Line("Resuming coroutine with parameter 3 in this thread:");
      Coroutine.GetGlobal("co");
      Coroutine.PushInteger(3);
      Coroutine_Status := Coroutine.resume(L, 1);
      Put("Coroutine status : " & Thread_Status'Image(Coroutine_Status));
      Put(" Result: "); Put(Coroutine.ToNumber(-1)); New_Line;
      while Coroutine_Status = YIELD loop
         Coroutine_Status := Coroutine.resume(L, 1);
         Put("Coroutine status : " & Thread_Status'Image(Coroutine_Status));
         Put(" Result: "); Put(Coroutine.ToNumber(-1)); New_Line;
      end loop;
   end;
   New_Line;

   L.Pop(L.GetTop);
   declare
      S : Lua_Reference := R;
   begin
      Put_Line("Retrieving a copy of reference saved earlier...");
      L.Get(S);
      Print_Stack(L);
   end;
   Put_Line("Retrieving reference saved earlier...");
   L.Get(R);
   Print_Stack(L);
   New_Line;

end Functions_Example;

-- Functions_Example
-- A example of using the Ada 2012 interface to Lua for functions / closures etc

-- Copyright (c) 2015, James Humphry - see LICENSE.md for terms

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Long_Float_Text_IO; use Ada.Long_Float_Text_IO;
with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
with Ada.Characters.Latin_1;

with Lua; use Lua;
with Lua.Libs;
with Lua.Util; use Lua.Util;

with Example_AdaFunctions;

procedure Functions_Example is
   L : Lua_State;
   Success : Thread_Status;
   R : Lua_Reference;

   LF : Character renames Ada.Characters.Latin_1.LF;
   Coroutine_Source : String := "" &
     "function co (x) " & LF &
     " for i = 1, x do " & LF &
     "  yield(i) " & LF &
     " end " & LF &
     " return -1 " & LF &
     " end " & LF &
     "";

begin

   Put_Line("A simple example of using Lua and Ada functions together");

   Put("Lua version: ");
   Put(Item => L.Version, Aft => 0, Exp => 0);
   New_Line; New_Line;

   Put_Line("Loading chunk: function f (x) return 2*x end");
   Success := L.LoadString("function f (x) return 2*x end");
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   L.Call(0, 0);
   Put_Line("Compiled chunk.");
   Put("Result of calling f (3): ");
   L.PushInteger(3);
   L.Call_Function(name => "f", nargs => 1, nresults => 1);
   Put(L.ToNumber(-1), Aft => 0, Exp => 0); New_Line;
   New_Line;

   Put_Line("Saving a reference to the top of the stack and clearing it.");
   R := Ref(L);
   L.Pop(L.GetTop);
   Print_Stack(L);
   Put_Line("Retrieving reference...");
   L.Get(R);
   Print_Stack(L);
   New_Line;

   Put_Line("Loading IO library and running example Lua file");
   Libs.Require_Standard_Library(L, LIbs.IO_Lib);
   Success := L.LoadFile("examples/example_lua.lua");
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   if Success = OK then
      L.Call(0, 0);
      Put_Line("Compiled chunk. Result of calling triangle (5):");
      L.PushNumber(5.0);
      L.Call_Function(name => "triangle", nargs => 1, nresults => 0);
   end if;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction foobar in Lua");
   L.Register("foobar", AdaFunction'(Example_AdaFunctions.Foobar'Access));
   Success := L.LoadString("baz = foobar(5.0)");
   Put_Line("Loading code snippet 'baz = foobar(5.0)'" &
            (if Success /= OK then " not" else "") & " successful.");
   Put_Line("Calling 'baz = foobar(5.0)' from Lua");
   L.Call(0, 0);
   Put("baz = ");
   L.GetGlobal("baz");
   Put(L.ToNumber(-1), Aft => 0, Exp => 0); New_Line;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Checking foobar can be retrieved");
   L.GetGlobal("foobar");
   if not L.IsAdaFunction(-1) then
      Put_Line("Error - foobar does not contain an AdaFunction?");
   end if;
   if L.ToAdaFunction(-1) = AdaFunction'(Example_AdaFunctions.Foobar'Access) then
      Put_Line("AdaFunction foobar retrieved successfully from Lua");
   else
      Put_Line("AdaFunction foobar was NOT retrieved from Lua");
   end if;
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction multret in Lua");
   L.Register("multret", AdaFunction'(Example_AdaFunctions.Multret'Access));
   Put_Line("Calling 'multret(5)' from Lua");
   L.PushInteger(5);
   L.Call_Function(name => "multret", nargs => 1, nresults => MultRet_Sentinel);
   Print_Stack(L);
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Registering an AdaFunction closure (with upvalue 2.0) in Lua");
   L.PushNumber(2.0);
   L.PushAdaClosure(AdaFunction'(Example_AdaFunctions.Closure'Access), 1);
   L.SetGlobal("closure");
   Put_Line("Calling 'closure(3.5)' from Lua");
   L.PushNumber(3.5);
   L.Call_Function(name => "closure", nargs => 1, nresults => MultRet_Sentinel);
   Print_Stack(L);
   New_Line;

   L.Pop(L.GetTop);
   Put_Line("Now to look at using coroutines");
   Libs.Add_Yield_Function(L);
   Put_Line("Loading coroutine source: ");
   Put_Line(Coroutine_Source);
   Success := L.LoadString(Coroutine_Source);
   Put_Line("Load" & (if Success /= OK then " not" else "") & " successful.");
   L.Call(0, 0);
   Put_Line("Compiled coroutine code.");
   declare
      Coroutine : Lua_Thread := L.NewThread;
      Coroutine_Status : Thread_Status;
   begin
      Put_Line("New thread created");
      Put_Line("Resuming coroutine with parameter 3 in this thread:");
      Coroutine.GetGlobal("co");
      Coroutine.PushInteger(3);
      Coroutine_Status := Coroutine.resume(L, 1);
      Put("Coroutine status : " & Thread_Status'Image(Coroutine_Status));
      Put(" Result: "); Put(Coroutine.ToNumber(-1)); New_Line;
      L.Pop(1); -- argument no longer needed in this example
      while Coroutine_Status = YIELD loop
         Coroutine_Status := Coroutine.resume(from => L, nargs => 0);
         Put("Coroutine status : " & Thread_Status'Image(Coroutine_Status));
         Put(" Result: "); Put(Coroutine.ToNumber(-1)); New_Line;
      end loop;
   end;
   New_Line;

   L.Pop(L.GetTop);
   declare
      S : Lua_Reference := R;
   begin
      Put_Line("Retrieving a copy of reference saved earlier...");
      L.Get(S);
      Print_Stack(L);
   end;
   Put_Line("Retrieving reference saved earlier...");
   L.Get(R);
   Print_Stack(L);
   New_Line;

end Functions_Example;

Correct example usage of coroutine

Correct example usage of coroutine

In the example for using coroutines, the coroutine was only accepting a
value the first time, so it is superfluous to keep passing it to the
Lua code.


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      procedure Delete (Self : in Manager; Obj : in out Manager_Access)
        is abstract;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 2009, 2010, 2014, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
with Util.Beans.Objects;
with Util.Beans.Basic;
private with Util.Concurrent.Counters;
private with Util.Beans.Objects.Maps;
package Util.Properties is

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

   function "+" (S : String) return Value renames To_Unbounded_String;

   function "-" (S : Value) return String renames To_String;

   --  The manager holding the name/value pairs and providing the operations
   --  to get and set the properties.
   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with private;
   type Manager_Access is access all Manager'Class;

   --  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 Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in Value) return Boolean;

   --  Returns TRUE if the property exists.
   function Exists (Self : in Manager'Class;
                    Name : in String) return Boolean;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return String;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in String) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return Value;

   --  Returns the property value.  Raises an exception if not found.
   function Get (Self : in Manager'Class;
                 Name : in Value) return String;

   --  Returns the property value or Default if it does not exist.
   function Get (Self : in Manager'Class;
                 Name : in String;
                 Default : in String) return String;

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in String);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in String;
                  Item : in Value);

   --  Set the value of the property.  The property is created if it
   --  does not exists.
   procedure Set (Self : in out Manager'Class;
                  Name : in Unbounded_String;
                  Item : in Value);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in String);

   --  Remove the property given its name.  If the property does not
   --  exist, raises NO_PROPERTY exception.
   procedure Remove (Self : in out Manager'Class;
                     Name : in Value);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Self    : in Manager'Class;
                      Process : access procedure (Name, Item : Value));

   type Name_Array is array (Natural range <>) of Value;

   --  Return the name of the properties defined in the manager.
   --  When a prefix is specified, only the properties starting with
   --  the prefix are returned.
   function Get_Names (Self   : in Manager;
                       Prefix : in String := "") return Name_Array;

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Load_Properties (Self   : in out Manager'Class;
                              File   : in Ada.Text_IO.File_Type;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.  When a prefix is specified, keep
   --  only the properties that starts with the prefix.  When Strip is True,
   --  the prefix part is removed from the property name.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "";
                              Strip  : in Boolean := False);

   --  Save the properties in the given file path.
   procedure Save_Properties (Self   : in out Manager'Class;
                              Path   : in String;
                              Prefix : in String := "");

   --  Copy the properties from FROM which start with a given prefix.
   --  If the prefix is empty, all properties are copied.  When Strip is True,
   --  the prefix part is removed from the property name.
   procedure Copy (Self   : in out Manager'Class;
                   From   : in Manager'Class;
                   Prefix : in String := "";
                   Strip  : in Boolean := False);

private

   --  Abstract interface for the implementation of Properties
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is abstract limited new Util.Beans.Basic.Bean with record
         Count : Util.Concurrent.Counters.Counter;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

      --  Returns TRUE if the property exists.
      function Exists (Self : in Manager; Name : in String)
                       return Boolean is abstract;

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in Value) is abstract;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is abstract;

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                            return Manager_Access is abstract;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is abstract;

   end Interface_P;

   procedure Set_Property_Implementation (Self : in out Manager;
                                          Impl : in Interface_P.Manager_Access);

   --  Create a property implementation if there is none yet.
   procedure Check_And_Create_Impl (Self : in out Manager);

   type Manager is new Ada.Finalization.Controlled and Util.Beans.Basic.Bean with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Remove the Delete operation because we don't need it


-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 2010, 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.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

--  == Session ==
--  The <tt>ADO.Sessions</tt> package defines the control and management of database sessions.
--  The database session is represented by the <tt>Session</tt> or <tt>Master_Session</tt> types.
--
--  @include ado-sessions-factory.ads
--
package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;
--
--     type Session_Proxy is limited record
--        Counter : Util.Concurrent.Counters.Counter;
--        Session : Session_Record_Access;
--        Factory : Object_Factory_Access;
--     end record;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access all ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "");
   pragma Inline (Check_Session);

end ADO.Sessions;

-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 2010, 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 Ada.Finalization;

with ADO.Schemas;
with ADO.Statements;
with ADO.Objects;
with ADO.Objects.Cache;
with ADO.Databases;
with ADO.Queries;
with ADO.SQL;

with Util.Concurrent.Counters;
limited with ADO.Sequences;
limited with ADO.Schemas.Entities;

--  == Session ==
--  The <tt>ADO.Sessions</tt> package defines the control and management of database sessions.
--  The database session is represented by the <tt>Session</tt> or <tt>Master_Session</tt> types.
--
--  @include ado-sessions-factory.ads
--
package ADO.Sessions is

   use ADO.Statements;

   --  Raised for all errors reported by the database
   DB_Error : exception;

   --  Raised if the database connection is not open.
   NOT_OPEN : exception;

   NOT_FOUND : exception;

   NO_DATABASE : exception;

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   type Object_Factory is tagged private;

   --  ---------
   --  Session
   --  ---------
   --  Read-only database connection (or slave connection).
   --
   type Session is tagged private;

   --  Get the session status.
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status;

   --  Close the session.
   procedure Close (Database : in out Session);

   --  Get the database connection.
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class;

   --  Attach the object to the session.
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class);

   --  Check if the session contains the object identified by the given key.
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean;

   --  Remove the object from the session cache.
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key);

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement;

   --  Create a query statement and initialize the SQL statement with the query definition.
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement;

   --  Create a query statement.  The statement is not prepared
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement;

   --  Load the database schema definition for the current database.
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition);

   --  ---------
   --  Master Session
   --  ---------
   --  Read-write session.
   --
   type Master_Session is new Session with private;

   --  Start a transaction.
   procedure Begin_Transaction (Database : in out Master_Session);

   --  Commit the current transaction.
   procedure Commit (Database : in out Master_Session);

   --  Rollback the current transaction.
   procedure Rollback (Database : in out Master_Session);

   --  Allocate an identifier for the table.
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class);

   --  Flush the objects that were modified.
   procedure Flush (Database : in out Master_Session);

   --  Create a delete statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement;

   --  Create an update statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement;

   --  Create an insert statement
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement;

   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access;

   type Session_Record is limited private;
   type Session_Record_Access is access all Session_Record;

private

   type Entity_Cache_Access is access constant ADO.Schemas.Entities.Entity_Cache;

   type Object_Factory is tagged record
      A : Integer;
   end record;
   type Object_Factory_Access is access all Object_Factory'Class;
--
--     type Session_Proxy is limited record
--        Counter : Util.Concurrent.Counters.Counter;
--        Session : Session_Record_Access;
--        Factory : Object_Factory_Access;
--     end record;

   --  The Session_Record maintains the connection information to the database for
   --  the duration of the session.  It also maintains a cache of application objects
   --  which is used when session objects are fetched (either through Load or a Find).
   --  The connection is released and the session record is deleted when the session
   --  is closed with Close.
   --
   --  For the lazy loading support, each object is associated with a shared Session_Proxy
   --  object that allows to give access to the session record associated with the object.
   --  When a session is closed, the Session_Proxy is not deleted but it is simply
   --  unlinked from the session record.
   type Session_Record is limited record
      Counter  : Util.Concurrent.Counters.Counter := Util.Concurrent.Counters.ONE;
      Database : ADO.Databases.Master_Connection;
      Proxy    : ADO.Objects.Session_Proxy_Access;
      Cache    : ADO.Objects.Cache.Object_Cache;
      Entities : Entity_Cache_Access;
   end record;

   type Session is new Ada.Finalization.Controlled with record
      Impl : Session_Record_Access := null;
   end record;

   overriding
   procedure Adjust (Object : in out Session);

   overriding
   procedure Finalize (Object : in out Session);

   type Factory_Access is access all ADO.Sequences.Factory;

   type Master_Session is new Session with record
      Sequences : Factory_Access;
   end record;

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "");
   pragma Inline (Check_Session);

end ADO.Sessions;

Declare the Load_Schema procedure

Declare the Load_Schema procedure


--                              -*- Mode: Ada -*-
--  Filename        : multiboot.ads
--  Description     : Provides access to the multiboot information from GRUB
--                    Legacy and GRUB 2.
--  Author          : Luke A. Guest
--  Created On      : Fri Jun 15 14:43:04 2012
--  Licence         : See LICENCE in the root directory.
with System;
with Interfaces; use Interfaces;

package Multiboot is
   subtype Magic_Values is Unsigned_32;

   Magic_Value : constant Magic_Values := 16#2BAD_B002#;

   type MB_Info;

   ----------------------------------------------------------------------------
   --  Multiboot information.
   ----------------------------------------------------------------------------
   type Features is
      record
         Memory               : Boolean; --  Bit 0
         Boot_Device          : Boolean; --  Bit 1
         Command_Line         : Boolean; --  Bit 2
         Modules              : Boolean; --  Bit 3
         Symbol_Table         : Boolean; --  Bit 4 - this is Aout only.
         Section_Header_Table : Boolean; --  Bit 5 - this is ELF only.
         BIOS_Memory_Map      : Boolean; --  Bit 6
         Drives               : Boolean; --  Bit 7
         ROM_Configuration    : Boolean; --  Bit 8
         Boot_Loader          : Boolean; --  Bit 9
         APM_Table            : Boolean; --  Bit 10
         Graphics_Table       : Boolean; --  Bit 11
      end record;

   for Features use
      record
         Memory               at 0 range 0 .. 0;
         Boot_Device          at 0 range 1 .. 1;
         Command_Line         at 0 range 2 .. 2;
         Modules              at 0 range 3 .. 3;
         Symbol_Table         at 0 range 4 .. 4;
         Section_Header_Table at 0 range 5 .. 5;
         BIOS_Memory_Map      at 0 range 6 .. 6;
         Drives               at 0 range 7 .. 7;
         ROM_Configuration    at 1 range 0 .. 0;
         Boot_Loader          at 1 range 1 .. 1;
         APM_Table            at 1 range 2 .. 2;
         Graphics_Table       at 1 range 3 .. 3;
      end record;

   for Features'Size use 32;

   ----------------------------------------------------------------------------
   --  Boot device information.
   ----------------------------------------------------------------------------
   type Boot_Devices is
      record
         Drive       : Unsigned_8;
         Partition_1 : Unsigned_8;
         Partition_2 : Unsigned_8;
         Partition_3 : Unsigned_8;
      end record;

   for Boot_Devices use
      record
         Drive       at 0 range 0 .. 7;
         Partition_1 at 1 range 0 .. 7;
         Partition_2 at 2 range 0 .. 7;
         Partition_3 at 3 range 0 .. 7;
      end record;

   for Boot_Devices'Size use 32;

   Invalid_Partition : constant Unsigned_8 := 16#ff#;

   ----------------------------------------------------------------------------
   --  Memory information.
   --  These values are in KB
   ----------------------------------------------------------------------------
   type Memory_Info is
      record
         Upper : Unsigned_32;
         Lower : Unsigned_32;
      end record;

   pragma Convention (C, Memory_Info);

   ----------------------------------------------------------------------------
   --  Loadable module information.
   ----------------------------------------------------------------------------
   type Modules is
      record
         First    : System.Address; --  Address of module start .. end.
         Last     : System.Address;
         Data     : System.Address; --  NULL terminated C string.
         Reserved : Unsigned_32;    --  Should be 0.
      end record;

   type Modules_Array is array (Natural range <>) of Modules;

   pragma Convention (C, Modules_Array);

   --  type Modules_Array_Access is access Modules_Array;

   --  pragma Convention (C, Modules_Array_Access);

   type Modules_Info is
      record
         Count : Unsigned_32;
         First : System.Address;
      end record;

   ----------------------------------------------------------------------------
   --  Symbols information.
   ----------------------------------------------------------------------------
   pragma Convention (C, Modules_Info);

   type Symbols_Variant is (Aout, ELF);

   function Get_Symbols_Variant return Symbols_Variant;

   ----------------------------------------------------------------------------
   --  a.out symbols or ELF sections
   --
   --  TODO: a.out only - This can be implemented by anyone who wants to use
   --  aout.
   --
   --  From what I can tell from the spec, Addr points to a size followed by
   --  an array of a.out nlist structures. This is then followed by a size
   --  of a set of strings, then the sizeof (unsigned), then the strings
   --  (NULL terminated).
   --
   --  Table_Size and String_Size are the same as the ones listed above.
   ----------------------------------------------------------------------------
   type Symbols (Variant : Symbols_Variant := ELF) is
      record
         case Variant is
            when Aout =>
               Table_Size  : Unsigned_32;
               String_Size : Unsigned_32;
               Aout_Addr   : System.Address;
               Reserved    : Unsigned_32;     --  Always 0.
            when ELF =>
               Number      : Unsigned_32;
               Size        : Unsigned_32;
               ELF_Addr    : System.Address;
               Shndx       : Unsigned_32;
         end case;
      end record;

   pragma Convention (C, Symbols);
   pragma Unchecked_Union (Symbols);

   ----------------------------------------------------------------------------
   --  Memory map information.
   ----------------------------------------------------------------------------
   type Memory_Type is range Unsigned_32'First .. Unsigned_32'Last;

   for Memory_Type'Size use 32;

   Memory_Available : constant Memory_Type := 1;
   Memory_Reserved  : constant Memory_Type := 2;

   type Memory_Map_Entry is
      record
         Size            : Unsigned_32;
         Base_Address    : Long_Long_Integer;
         Length_In_Bytes : Long_Long_Integer;
         Sort            : Memory_Type;
      end record;

   type Memory_Map_Entry_Access is access Memory_Map_Entry;

   type Memory_Map_Info is
      record
         Length : Unsigned_32;
         Addr   : Unsigned_32;
      end record;

   pragma Convention (C, Memory_Map_Info);

   ----------------------------------------------------------------------------
   --  Returns null on failure or if the memory map doesn't exist.
   ----------------------------------------------------------------------------
   function First_Memory_Map_Entry return Memory_Map_Entry_Access;

   ----------------------------------------------------------------------------
   --  Returns null on failure or if we have seen all of the memory map.
   ----------------------------------------------------------------------------
   function Next_Memory_Map_Entry
     (Current : Memory_Map_Entry_Access) return Memory_Map_Entry_Access;

   ----------------------------------------------------------------------------
   --  Drives information.
   --  TODO: Complete
   ----------------------------------------------------------------------------
   type Drives_Info is
      record
         Length : Unsigned_32;
         Addr   : Unsigned_32;
      end record;

   pragma Convention (C, Drives_Info);

   ----------------------------------------------------------------------------
   --  APM table.
   ----------------------------------------------------------------------------
   type APM_Table is
      record
         Version         : Unsigned_16;
         C_Seg           : Unsigned_16;
         Offset          : Unsigned_32;
         C_Seg_16        : Unsigned_16;
         D_Seg           : Unsigned_16;
         Flags           : Unsigned_16;
         C_Seg_Length    : Unsigned_16;
         C_Seg_16_Length : Unsigned_16;
         D_Seg_Length    : Unsigned_16;
      end record;

   pragma Convention (C, APM_Table);

   type APM_Table_Access is access APM_Table;

   function Get_APM_Table return APM_Table_Access;

   ----------------------------------------------------------------------------
   --  Graphics information.
   ----------------------------------------------------------------------------
   type VBE_Info is
      record
         Control_Info  : Unsigned_32;
         Mode_Info     : Unsigned_32;
         Mode          : Unsigned_32;
         Interface_Seg : Unsigned_32;
         Interface_Off : Unsigned_32;
         Interface_Len : Unsigned_32;
      end record;

   pragma Convention (C, VBE_Info);

   type MB_Info is
      record
         Flags            : Features;
         Memory           : Memory_Info;
         Boot_Device      : Boot_Devices;
         Cmd_Line         : System.Address;  --  NULL terminated C string.
         Modules          : Modules_Info;
         Syms             : Symbols;
         Memory_Map       : Memory_Map_Info;
         Drives           : Drives_Info;
         Config_Table     : System.Address;  --  TODO: Points to BIOS table.
         Boot_Loader_Name : System.Address;  --  NULL terminated C string.
         APM              : System.Address;
         VBE              : VBE_Info;
      end record;

   pragma Convention (C, MB_Info);

   --  We need to import the "mbd" symbol...
   Info_Address : constant Unsigned_32;

   pragma Import (Assembly, Info_Address, "mbd");

   Info : constant MB_Info;

   --  So we can use the address stored at that location.
   for Info'Address use System'To_Address (Info_Address);

   pragma Volatile (Info);
   pragma Import (C, Info);

   ----------------------------------------------------------------------------
   --  Magic number.
   ----------------------------------------------------------------------------
   Magic : constant Magic_Values;

   pragma Warnings (Off);
   pragma Import (Assembly, Magic, "magic");
   pragma Warnings (On);
end Multiboot;

--                              -*- Mode: Ada -*-
--  Filename        : multiboot.ads
--  Description     : Provides access to the multiboot information from GRUB
--                    Legacy and GRUB 2.
--  Author          : Luke A. Guest
--  Created On      : Fri Jun 15 14:43:04 2012
--  Licence         : See LICENCE in the root directory.
with System;
with Interfaces; use Interfaces;

package Multiboot is
   subtype Magic_Values is Unsigned_32;

   Magic_Value : constant Magic_Values := 16#2BAD_B002#;

   type MB_Info;

   ----------------------------------------------------------------------------
   --  Multiboot information.
   ----------------------------------------------------------------------------
   type Features is
      record
         Memory               : Boolean; --  Bit 0
         Boot_Device          : Boolean; --  Bit 1
         Command_Line         : Boolean; --  Bit 2
         Modules              : Boolean; --  Bit 3
         Symbol_Table         : Boolean; --  Bit 4 - this is Aout only.
         Section_Header_Table : Boolean; --  Bit 5 - this is ELF only.
         BIOS_Memory_Map      : Boolean; --  Bit 6
         Drives               : Boolean; --  Bit 7
         ROM_Configuration    : Boolean; --  Bit 8
         Boot_Loader          : Boolean; --  Bit 9
         APM_Table            : Boolean; --  Bit 10
         Graphics_Table       : Boolean; --  Bit 11
      end record;

   for Features use
      record
         Memory               at 0 range 0 .. 0;
         Boot_Device          at 0 range 1 .. 1;
         Command_Line         at 0 range 2 .. 2;
         Modules              at 0 range 3 .. 3;
         Symbol_Table         at 0 range 4 .. 4;
         Section_Header_Table at 0 range 5 .. 5;
         BIOS_Memory_Map      at 0 range 6 .. 6;
         Drives               at 0 range 7 .. 7;
         ROM_Configuration    at 1 range 0 .. 0;
         Boot_Loader          at 1 range 1 .. 1;
         APM_Table            at 1 range 2 .. 2;
         Graphics_Table       at 1 range 3 .. 3;
      end record;

   for Features'Size use 32;

   ----------------------------------------------------------------------------
   --  Boot device information.
   ----------------------------------------------------------------------------
   type Boot_Devices is
      record
         Drive       : Unsigned_8;
         Partition_1 : Unsigned_8;
         Partition_2 : Unsigned_8;
         Partition_3 : Unsigned_8;
      end record;

   for Boot_Devices use
      record
         Drive       at 0 range 0 .. 7;
         Partition_1 at 1 range 0 .. 7;
         Partition_2 at 2 range 0 .. 7;
         Partition_3 at 3 range 0 .. 7;
      end record;

   for Boot_Devices'Size use 32;

   Invalid_Partition : constant Unsigned_8 := 16#ff#;

   ----------------------------------------------------------------------------
   --  Memory information.
   --  These values are in KB
   ----------------------------------------------------------------------------
   type Memory_Info is
      record
         Upper : Unsigned_32;
         Lower : Unsigned_32;
      end record;

   pragma Convention (C, Memory_Info);

   ----------------------------------------------------------------------------
   --  Loadable module information.
   ----------------------------------------------------------------------------
   type Modules is
      record
         First    : System.Address; --  Address of module start .. end.
         Last     : System.Address;
         Data     : System.Address; --  NULL terminated C string.
         Reserved : Unsigned_32;    --  Should be 0.
      end record;

   type Modules_Array is array (Natural range <>) of Modules;

   pragma Convention (C, Modules_Array);

   --  type Modules_Array_Access is access Modules_Array;

   --  pragma Convention (C, Modules_Array_Access);

   type Modules_Info is
      record
         Count : Unsigned_32;
         First : System.Address;
      end record;

   ----------------------------------------------------------------------------
   --  Symbols information.
   ----------------------------------------------------------------------------
   pragma Convention (C, Modules_Info);

   type Symbols_Variant is (Aout, ELF);

   function Get_Symbols_Variant return Symbols_Variant;

   ----------------------------------------------------------------------------
   --  a.out symbols or ELF sections
   --
   --  TODO: a.out only - This can be implemented by anyone who wants to use
   --  aout.
   --
   --  From what I can tell from the spec, Addr points to a size followed by
   --  an array of a.out nlist structures. This is then followed by a size
   --  of a set of strings, then the sizeof (unsigned), then the strings
   --  (NULL terminated).
   --
   --  Table_Size and String_Size are the same as the ones listed above.
   ----------------------------------------------------------------------------
   type Symbols (Variant : Symbols_Variant := ELF) is
      record
         case Variant is
            when Aout =>
               Table_Size  : Unsigned_32;
               String_Size : Unsigned_32;
               Aout_Addr   : System.Address;
               Reserved    : Unsigned_32;     --  Always 0.
            when ELF =>
               Number      : Unsigned_32;
               Size        : Unsigned_32;
               ELF_Addr    : System.Address;
               Shndx       : Unsigned_32;
         end case;
      end record;

   pragma Convention (C, Symbols);
   pragma Unchecked_Union (Symbols);

   ----------------------------------------------------------------------------
   --  Memory map information.
   ----------------------------------------------------------------------------
   type Memory_Type is range Unsigned_32'First .. Unsigned_32'Last;

   for Memory_Type'Size use 32;

   Memory_Available : constant Memory_Type := 1;
   Memory_Reserved  : constant Memory_Type := 2;

   type Memory_Map_Entry is
      record
         Size            : Unsigned_32;
         Base_Address    : Long_Long_Integer;
         Length_In_Bytes : Long_Long_Integer;
         Sort            : Memory_Type;
      end record;

   type Memory_Map_Entry_Access is access Memory_Map_Entry;

   type Memory_Map_Info is
      record
         Length : Unsigned_32;
         Addr   : Unsigned_32;
      end record;

   pragma Convention (C, Memory_Map_Info);

   ----------------------------------------------------------------------------
   --  Returns null on failure or if the memory map doesn't exist.
   ----------------------------------------------------------------------------
   function First_Memory_Map_Entry return Memory_Map_Entry_Access;

   ----------------------------------------------------------------------------
   --  Returns null on failure or if we have seen all of the memory map.
   ----------------------------------------------------------------------------
   function Next_Memory_Map_Entry
     (Current : Memory_Map_Entry_Access) return Memory_Map_Entry_Access;

   ----------------------------------------------------------------------------
   --  Drives information.
   --  TODO: Complete
   ----------------------------------------------------------------------------
   type Drives_Info is
      record
         Length : Unsigned_32;
         Addr   : Unsigned_32;
      end record;

   pragma Convention (C, Drives_Info);

   ----------------------------------------------------------------------------
   --  APM table.
   ----------------------------------------------------------------------------
   type APM_Table is
      record
         Version         : Unsigned_16;
         C_Seg           : Unsigned_16;
         Offset          : Unsigned_32;
         C_Seg_16        : Unsigned_16;
         D_Seg           : Unsigned_16;
         Flags           : Unsigned_16;
         C_Seg_Length    : Unsigned_16;
         C_Seg_16_Length : Unsigned_16;
         D_Seg_Length    : Unsigned_16;
      end record;

   pragma Convention (C, APM_Table);

   type APM_Table_Access is access APM_Table;

   function Get_APM_Table return APM_Table_Access;

   ----------------------------------------------------------------------------
   --  Graphics information.
   ----------------------------------------------------------------------------
   type VBE_Info is
      record
         Control_Info  : Unsigned_32;
         Mode_Info     : Unsigned_32;
         Mode          : Unsigned_32;
         Interface_Seg : Unsigned_32;
         Interface_Off : Unsigned_32;
         Interface_Len : Unsigned_32;
      end record;

   pragma Convention (C, VBE_Info);

   type MB_Info is
      record
         Flags            : Features;
         Memory           : Memory_Info;
         Boot_Device      : Boot_Devices;
         Cmd_Line         : System.Address;  --  NULL terminated C string.
         Modules          : Modules_Info;
         Syms             : Symbols;
         Memory_Map       : Memory_Map_Info;
         Drives           : Drives_Info;
         Config_Table     : System.Address;  --  TODO: Points to BIOS table.
         Boot_Loader_Name : System.Address;  --  NULL terminated C string.
         APM              : System.Address;
         VBE              : VBE_Info;
      end record;

   pragma Convention (C, MB_Info);

   --  We need to import the "mbd" symbol...
   Info_Address : constant Unsigned_32;

   pragma Import (Assembly, Info_Address, "mbd");

   Info : constant MB_Info;

   --  So we can use the address stored at that location.
   for Info'Address use System'To_Address (Info_Address);

   pragma Volatile (Info);
   pragma Import (C, Info);

   ----------------------------------------------------------------------------
   --  Magic number.
   ----------------------------------------------------------------------------
   Magic : constant Magic_Values;

   pragma Import (Assembly, Magic, "magic");
end Multiboot;

Remove warning pragma, no longer required.