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

with Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  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 Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER or From.Kind = T_ENTITY_TYPE);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      elsif Name = "isNullable" then
         return Util.Beans.Objects.To_Object (From.Nullable);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_FLOAT =>
            return "float";

         when T_ENTITY_TYPE =>
            return "entity_type";

         when T_BLOB =>
            return "blob";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   --  ------------------------------
   --  Get the type name according to the mapping definition.
   --  ------------------------------
   function Get_Type_Name (Name : in Ada.Strings.Unbounded.Unbounded_String) return String is
      T : constant Mapping_Definition_Access := Find_Type (Name, False);
   begin
      if T = null then
         return To_String (Name);
      else
         return To_String (T.Target);
      end if;
   end Get_Type_Name;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

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

with Util.Log.Loggers;

--  The Gen.Model.Mappings package controls the mappings to convert an XML
--  type into the Ada type.
package body Gen.Model.Mappings is

   use Ada.Strings.Unbounded;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Gen.Model.Mappings");

   Types : Mapping_Maps.Map;

   Mapping_Name : Unbounded_String;

   --  ------------------------------
   --  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 Mapping_Definition;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "name" then
         return Util.Beans.Objects.To_Object (From.Target);
      elsif Name = "isBoolean" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BOOLEAN);
      elsif Name = "isInteger" then
         return Util.Beans.Objects.To_Object (From.Kind = T_INTEGER or From.Kind = T_ENTITY_TYPE);
      elsif Name = "isFloat" then
         return Util.Beans.Objects.To_Object (From.Kind = T_FLOAT);
      elsif Name = "isString" then
         return Util.Beans.Objects.To_Object (From.Kind = T_STRING);
      elsif Name = "isIdentifier" then
         return Util.Beans.Objects.To_Object (From.Kind = T_IDENTIFIER);
      elsif Name = "isDate" then
         return Util.Beans.Objects.To_Object (From.Kind = T_DATE);
      elsif Name = "isBlob" then
         return Util.Beans.Objects.To_Object (From.Kind = T_BLOB);
      elsif Name = "isEnum" then
         return Util.Beans.Objects.To_Object (From.Kind = T_ENUM);
      elsif Name = "isPrimitiveType" then
         return Util.Beans.Objects.To_Object (From.Kind /= T_TABLE and From.Kind /= T_BLOB);
      elsif Name = "isNullable" then
         return Util.Beans.Objects.To_Object (From.Nullable);
      else
         return Definition (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Get the type name.
   --  ------------------------------
   function Get_Type_Name (From : Mapping_Definition) return String is
   begin
      case From.Kind is
         when T_BOOLEAN =>
            return "boolean";

         when T_INTEGER =>
            return "integer";

         when T_DATE =>
            return "date";

         when T_IDENTIFIER =>
            return "identifier";

         when T_STRING =>
            return "string";

         when T_FLOAT =>
            return "float";

         when T_ENTITY_TYPE =>
            return "entity_type";

         when T_BLOB =>
            return "blob";

         when T_ENUM =>
            return From.Get_Name;

         when others =>
            return From.Get_Name;

      end case;
   end Get_Type_Name;

   --  ------------------------------
   --  Find the mapping for the given type name.
   --  ------------------------------
   function Find_Type (Name       : in Ada.Strings.Unbounded.Unbounded_String;
                       Allow_Null : in Boolean)
                       return Mapping_Definition_Access is
      Pos : constant Mapping_Maps.Cursor := Types.Find (Mapping_Name & Name);
   begin
      if not Mapping_Maps.Has_Element (Pos) then
         Log.Info ("Type '{0}' not found in mapping table '{1}'",
                   To_String (Name), To_String (Mapping_Name));
         return null;
      elsif Allow_Null then
         if Mapping_Maps.Element (Pos).Allow_Null = null then
            Log.Info ("Type '{0}' does not allow a null value in mapping table '{1}'",
                       To_String (Name), To_String (Mapping_Name));
            return Mapping_Maps.Element (Pos);
         end if;
         return Mapping_Maps.Element (Pos).Allow_Null;
      else
         return Mapping_Maps.Element (Pos);
      end if;
   end Find_Type;

   --  ------------------------------
   --  Get the type name according to the mapping definition.
   --  ------------------------------
   function Get_Type_Name (Name : in Ada.Strings.Unbounded.Unbounded_String) return String is
      T : constant Mapping_Definition_Access := Find_Type (Name, False);
   begin
      if T = null then
         return To_String (Name);
      else
         return To_String (T.Target);
      end if;
   end Get_Type_Name;

   procedure Register_Type (Name    : in String;
                            Mapping : in Mapping_Definition_Access;
                            Kind    : in Basic_Type) is
      N    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (Name);
      Pos  : constant Mapping_Maps.Cursor := Types.Find (N);
   begin
      Log.Debug ("Register type '{0}'", Name);

      if not Mapping_Maps.Has_Element (Pos) then
         Mapping.Kind := Kind;
         Types.Insert (N, Mapping);
      end if;
   end Register_Type;

   --  ------------------------------
   --  Register a type mapping From that is mapped to Target.
   --  ------------------------------
   procedure Register_Type (Target     : in String;
                            From       : in String;
                            Kind       : in Basic_Type;
                            Allow_Null : in Boolean) is
      Name    : constant Unbounded_String := Mapping_Name & To_Unbounded_String (From);
      Pos     : constant Mapping_Maps.Cursor := Types.Find (Name);
      Mapping : Mapping_Definition_Access;
      Found   : Boolean;
   begin
      Log.Debug ("Register type '{0}' mapped to '{1}' type {2}",
                 From, Target, Basic_Type'Image (Kind));

      Found := Mapping_Maps.Has_Element (Pos);
      if Found then
         Mapping := Mapping_Maps.Element (Pos);
      else
         Mapping := new Mapping_Definition;
         Mapping.Set_Name (From);
         Types.Insert (Name, Mapping);
      end if;
      if Allow_Null then
         Mapping.Allow_Null := new Mapping_Definition;
         Mapping.Allow_Null.Target := To_Unbounded_String (Target);
         Mapping.Allow_Null.Kind := Kind;
         Mapping.Allow_Null.Nullable := True;
         if not Found then
            Mapping.Target := To_Unbounded_String (Target);
            Mapping.Kind   := Kind;
         end if;
      else
         Mapping.Target := To_Unbounded_String (Target);
         Mapping.Kind   := Kind;
      end if;
   end Register_Type;

   --  ------------------------------
   --  Setup the type mapping for the language identified by the given name.
   --  ------------------------------
   procedure Set_Mapping_Name (Name : in String) is
   begin
      Log.Info ("Using type mapping {0}", Name);

      Mapping_Name := To_Unbounded_String (Name & ".");
   end Set_Mapping_Name;

end Gen.Model.Mappings;

Add isFloat attribute to the type mapping


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

with Ada.Calendar;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Simple_Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;
with Natools.Web.Fallback_Render;

package body Natools.Web.Simple_Pages is

   Expiration_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!expire");

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Comment_List =>
            Data.Comment_List.Set (Arguments);

         when Components.Dates =>
            Containers.Set_Dates (Data.Dates, Arguments);

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class);

      procedure Render_Date (Log_Error : in Boolean);

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class) is
      begin
         Render_Page (Expression, Exchange, Page);
      end Re_Enter;

      procedure Render_Date (Log_Error : in Boolean) is
      begin
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Cursor : constant Containers.Date_Maps.Cursor
                 := Page.Dates.Find (Arguments.Current_Atom);
            begin
               if not Containers.Date_Maps.Has_Element (Cursor) then
                  if Log_Error then
                     Log (Severities.Error, "Unable to find date """
                       & S_Expressions.To_String (Arguments.Current_Atom)
                       & """ in page date map");
                  end if;

                  return;
               end if;

               Arguments.Next;

               declare
                  Item : constant Containers.Date
                    := Containers.Date_Maps.Element (Cursor);
               begin
                  S_Expressions.Templates.Dates.Render
                    (Exchange, Arguments, Item.Time, Item.Offset);
               end;
            end;
         end if;
      end Render_Date;

      package Commands renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            Fallback_Render
              (Exchange, Name, Arguments,
               "simple page",
               Re_Enter'Access, Page.Elements);

         when Commands.Comment_List =>
            Comments.Render (Exchange, Page.Comment_List, Arguments);

         when Commands.Date =>
            Render_Date (True);

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.If_No_Date =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom
              and then not Page.Dates.Contains (Arguments.Current_Atom)
            then
               Arguments.Next;
               Render_Page (Arguments, Exchange, Page);
            end if;

         when Commands.Optional_Date =>
            Render_Date (False);

         when Commands.Path =>
            Exchange.Append (Page.Web_Path.Query);

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);
      end case;
   end Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   not overriding procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data;
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);
      Read_Page (Expression, Page.all, Meaningless_Value);
      return Result;
   end Create;

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data'
        (File_Path => File_Path,
         Web_Path => Web_Path,
         Tags => <>,
         Self => null,
         Comment_List | Elements | Dates => <>);
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);

      Create_Page :
      declare
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path.Query));
      begin
         Read_Page (Reader, Page.all, Meaningless_Value);
      end Create_Page;

      return Result;
   end Create;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page (Expression, Exchange, Object);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom)
   is
      use type S_Expressions.Offset;
   begin
      if Extra_Path'Length = 9
        and then S_Expressions.To_String (Extra_Path) = "/comments"
      then
         Object.Ref.Update.Comment_List.Respond
           (Exchange, Extra_Path (Extra_Path'First + 9 .. Extra_Path'Last));
         return;
      end if;

      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Expression := Exchange.Site.Get_Template
           (Accessor.Data.Elements,
            Expression,
            Exchange.Site.Default_Template,
            Lookup_Element => True,
            Lookup_Template => True,
            Lookup_Name => True);

         Render_Page (Expression, Exchange, Accessor.Data.all);
      end;
   end Respond;

   -----------------------
   -- Page Constructors --
   -----------------------

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class is
   begin
      return Loader'(File_Path
        => S_Expressions.Atom_Ref_Constructors.Create (File));
   end Create;

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom)
   is
      Page : constant Page_Ref := Create
        (Object.File_Path,
         S_Expressions.Atom_Ref_Constructors.Create (Path));
   begin
      Expiration_Check :
      declare
         use type Ada.Calendar.Time;
         Accessor : constant Data_Refs.Accessor := Page.Ref.Query;
         Cursor : constant Containers.Date_Maps.Cursor
           := Accessor.Dates.Find (Expiration_Date_Key);
      begin
         if Containers.Date_Maps.Has_Element (Cursor)
           and then Containers.Date_Maps.Element (Cursor).Time
              < Ada.Calendar.Clock
         then
            return;
         end if;
      end Expiration_Check;

      Sites.Insert (Builder, Path, Page);
      Sites.Insert (Builder, Page.Get_Tags, Page);

      declare
         Mutator : constant Data_Refs.Mutator := Page.Ref.Update;
      begin
         Mutator.Comment_List.Load (Builder, Mutator.Self, Mutator.Web_Path);
      end;
   end Load;

   procedure Register_Loader (Site : in out Sites.Site) is
   begin
      Site.Register ("simple-page", Create'Access);
   end Register_Loader;

end Natools.Web.Simple_Pages;

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

with Ada.Calendar;
with Natools.S_Expressions.Atom_Ref_Constructors;
with Natools.S_Expressions.File_Readers;
with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Templates.Dates;
with Natools.Static_Maps.Web.Simple_Pages;
with Natools.Web.Error_Pages;
with Natools.Web.Exchanges;
with Natools.Web.Fallback_Render;

package body Natools.Web.Simple_Pages is

   Expiration_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!expire");
   Publication_Date_Key : constant S_Expressions.Atom
     := S_Expressions.To_Atom ("!publish");

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom);

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class);

   procedure Read_Page is new S_Expressions.Interpreter_Loop
     (Page_Data, Meaningless_Type, Execute);

   procedure Render_Page is new S_Expressions.Interpreter_Loop
     (Sites.Exchange, Page_Data, Render, Append);

   ---------------------------
   -- Page Data Constructor --
   ---------------------------

   procedure Execute
     (Data : in out Page_Data;
      Context : in Meaningless_Type;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      package Components renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Components.To_Component (S_Expressions.To_String (Name)) is
         when Components.Error =>
            Log (Severities.Error, "Unknown page component """
              & S_Expressions.To_String (Name) & '"');

         when Components.Comment_List =>
            Data.Comment_List.Set (Arguments);

         when Components.Dates =>
            Containers.Set_Dates (Data.Dates, Arguments);

         when Components.Elements =>
            Containers.Set_Expressions (Data.Elements, Arguments);

         when Components.Tags =>
            Tags.Append (Data.Tags, Arguments);
      end case;
   end Execute;

   -------------------
   -- Page Renderer --
   -------------------

   procedure Append
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Data : in S_Expressions.Atom)
   is
      pragma Unreferenced (Page);
   begin
      Exchange.Append (Data);
   end Append;

   procedure Render
     (Exchange : in out Sites.Exchange;
      Page : in Page_Data;
      Name : in S_Expressions.Atom;
      Arguments : in out S_Expressions.Lockable.Descriptor'Class)
   is
      use type S_Expressions.Events.Event;

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class);

      procedure Render_Date (Log_Error : in Boolean);

      procedure Re_Enter
        (Exchange : in out Sites.Exchange;
         Expression : in out S_Expressions.Lockable.Descriptor'Class) is
      begin
         Render_Page (Expression, Exchange, Page);
      end Re_Enter;

      procedure Render_Date (Log_Error : in Boolean) is
      begin
         if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
            declare
               Cursor : constant Containers.Date_Maps.Cursor
                 := Page.Dates.Find (Arguments.Current_Atom);
            begin
               if not Containers.Date_Maps.Has_Element (Cursor) then
                  if Log_Error then
                     Log (Severities.Error, "Unable to find date """
                       & S_Expressions.To_String (Arguments.Current_Atom)
                       & """ in page date map");
                  end if;

                  return;
               end if;

               Arguments.Next;

               declare
                  Item : constant Containers.Date
                    := Containers.Date_Maps.Element (Cursor);
               begin
                  S_Expressions.Templates.Dates.Render
                    (Exchange, Arguments, Item.Time, Item.Offset);
               end;
            end;
         end if;
      end Render_Date;

      package Commands renames Natools.Static_Maps.Web.Simple_Pages;
   begin
      case Commands.To_Command (S_Expressions.To_String (Name)) is
         when Commands.Unknown_Command =>
            Fallback_Render
              (Exchange, Name, Arguments,
               "simple page",
               Re_Enter'Access, Page.Elements);

         when Commands.Comment_List =>
            Comments.Render (Exchange, Page.Comment_List, Arguments);

         when Commands.Date =>
            Render_Date (True);

         when Commands.My_Tags =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom then
               declare
                  Prefix : constant S_Expressions.Atom
                    := Arguments.Current_Atom;
               begin
                  Arguments.Next;
                  Tags.Render
                    (Exchange,
                     Page.Tags,
                     Exchange.Site.Get_Tags,
                     Prefix,
                     Arguments);
               end;
            end if;

         when Commands.If_No_Date =>
            if Arguments.Current_Event = S_Expressions.Events.Add_Atom
              and then not Page.Dates.Contains (Arguments.Current_Atom)
            then
               Arguments.Next;
               Render_Page (Arguments, Exchange, Page);
            end if;

         when Commands.Optional_Date =>
            Render_Date (False);

         when Commands.Path =>
            Exchange.Append (Page.Web_Path.Query);

         when Commands.Tags =>
            Tags.Render
              (Exchange,
               Exchange.Site.Get_Tags,
               Arguments,
               Page.Tags);
      end case;
   end Render;

   -------------------------
   -- Page_Data Interface --
   -------------------------

   not overriding procedure Get_Element
     (Data : in Page_Data;
      Name : in S_Expressions.Atom;
      Element : out S_Expressions.Caches.Cursor;
      Found : out Boolean)
   is
      Cursor : constant Containers.Expression_Maps.Cursor
        := Data.Elements.Find (Name);
   begin
      Found := Containers.Expression_Maps.Has_Element (Cursor);

      if Found then
         Element := Containers.Expression_Maps.Element (Cursor);
      end if;
   end Get_Element;

   ----------------------
   -- Public Interface --
   ----------------------

   function Create
     (Expression : in out S_Expressions.Lockable.Descriptor'Class)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data;
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);
      Read_Page (Expression, Page.all, Meaningless_Value);
      return Result;
   end Create;

   function Create
     (File_Path, Web_Path : in S_Expressions.Atom_Refs.Immutable_Reference)
     return Page_Ref
   is
      Page : constant Data_Refs.Data_Access := new Page_Data'
        (File_Path => File_Path,
         Web_Path => Web_Path,
         Tags => <>,
         Self => null,
         Comment_List | Elements | Dates => <>);
      Result : constant Page_Ref := (Ref => Data_Refs.Create (Page));
   begin
      Page.Self := Tags.Visible_Access (Page);

      Create_Page :
      declare
         Reader : Natools.S_Expressions.File_Readers.S_Reader
           := Natools.S_Expressions.File_Readers.Reader
              (S_Expressions.To_String (File_Path.Query));
      begin
         Read_Page (Reader, Page.all, Meaningless_Value);
      end Create_Page;

      return Result;
   end Create;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Ref;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page
        (Expression,
         Exchange,
         Object.Ref.Query.Data.all);
   end Render;

   overriding procedure Render
     (Exchange : in out Sites.Exchange;
      Object : in Page_Data;
      Expression : in out S_Expressions.Lockable.Descriptor'Class) is
   begin
      Render_Page (Expression, Exchange, Object);
   end Render;

   overriding procedure Respond
     (Object : in out Page_Ref;
      Exchange : in out Sites.Exchange;
      Extra_Path : in S_Expressions.Atom)
   is
      use type S_Expressions.Offset;
   begin
      if Extra_Path'Length = 9
        and then S_Expressions.To_String (Extra_Path) = "/comments"
      then
         Object.Ref.Update.Comment_List.Respond
           (Exchange, Extra_Path (Extra_Path'First + 9 .. Extra_Path'Last));
         return;
      end if;

      if Extra_Path'Length > 0 then
         return;
      end if;

      declare
         Accessor : constant Data_Refs.Accessor := Object.Ref.Query;
         Expression : S_Expressions.Caches.Cursor;
      begin
         Check_Method :
         declare
            use Exchanges;
            Allowed : Boolean;
         begin
            Error_Pages.Check_Method
              (Exchange,
               (GET, HEAD),
               Allowed);

            if not Allowed then
               return;
            end if;
         end Check_Method;

         Expression := Exchange.Site.Get_Template
           (Accessor.Data.Elements,
            Expression,
            Exchange.Site.Default_Template,
            Lookup_Element => True,
            Lookup_Template => True,
            Lookup_Name => True);

         Render_Page (Expression, Exchange, Accessor.Data.all);
      end;
   end Respond;

   -----------------------
   -- Page Constructors --
   -----------------------

   function Create (File : in S_Expressions.Atom)
     return Sites.Page_Loader'Class is
   begin
      return Loader'(File_Path
        => S_Expressions.Atom_Ref_Constructors.Create (File));
   end Create;

   overriding procedure Load
     (Object : in out Loader;
      Builder : in out Sites.Site_Builder;
      Path : in S_Expressions.Atom)
   is
      Page : constant Page_Ref := Create
        (Object.File_Path,
         S_Expressions.Atom_Ref_Constructors.Create (Path));
   begin
      Time_Check :
      declare
         use type Ada.Calendar.Time;
         Now : constant Ada.Calendar.Time := Ada.Calendar.Clock;
         Accessor : constant Data_Refs.Accessor := Page.Ref.Query;
         Cursor : Containers.Date_Maps.Cursor
           := Accessor.Dates.Find (Expiration_Date_Key);
      begin
         if Containers.Date_Maps.Has_Element (Cursor)
           and then Containers.Date_Maps.Element (Cursor).Time < Now
         then
            return;
         end if;

         Cursor := Accessor.Dates.Find (Publication_Date_Key);

         if Containers.Date_Maps.Has_Element (Cursor)
           and then Containers.Date_Maps.Element (Cursor).Time >= Now
         then
            return;
         end if;
      end Time_Check;

      Sites.Insert (Builder, Path, Page);
      Sites.Insert (Builder, Page.Get_Tags, Page);

      declare
         Mutator : constant Data_Refs.Mutator := Page.Ref.Update;
      begin
         Mutator.Comment_List.Load (Builder, Mutator.Self, Mutator.Web_Path);
      end;
   end Load;

   procedure Register_Loader (Site : in out Sites.Site) is
   begin
      Site.Register ("simple-page", Create'Access);
   end Register_Loader;

end Natools.Web.Simple_Pages;

simple_pages: add a special date used to mark page publication time


--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../../License.txt

with CommonText;
with Ada.Calendar;
with Ada.Strings.Wide_Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;

package AdaBase.Results is

   package CT   renames CommonText;
   package AC   renames Ada.Calendar;
   package SUW  renames Ada.Strings.Wide_Unbounded;
   package SUWW renames Ada.Strings.Wide_Wide_Unbounded;

   subtype textual   is CT.Text;
   subtype textwide  is SUW.Unbounded_Wide_String;
   subtype textsuper is SUWW.Unbounded_Wide_Wide_String;

   TARGET_TYPE_TOO_NARROW : exception;
   CONVERSION_FAILED      : exception;
   UNSUPPORTED_CONVERSION : exception;
   COLUMN_DOES_NOT_EXIST  : exception;
   CONSTRUCTOR_DO_NOT_USE : exception;

   -------------------------------------------
   --  Supported Field Types (Standardized) --
   -------------------------------------------

   type nbyte1 is mod 2 ** 8;
   type nbyte2 is mod 2 ** 16;
   type nbyte3 is mod 2 ** 24;
   type nbyte4 is mod 2 ** 32;
   type nbyte8 is mod 2 ** 64;
   type byte8  is range -2 ** 63 .. 2 ** 63 - 1;
   type byte4  is range -2 ** 31 .. 2 ** 31 - 1;
   type byte3  is range -2 ** 23 .. 2 ** 23 - 1;
   type byte2  is range -2 ** 15 .. 2 ** 15 - 1;
   type byte1  is range -2 **  7 .. 2 **  7 - 1;
   type real9  is digits 9;
   type real18 is digits 18;

   subtype nbyte0 is Boolean;

   type chain is array (Positive range <>) of nbyte1;
   type enumtype is record
      enumeration : textual;
      index       : Natural;
   end record;
   type settype is array (Positive range <>) of enumtype;

   type nbyte0_access  is access all nbyte0;
   type nbyte1_access  is access all nbyte1;
   type nbyte2_access  is access all nbyte2;
   type nbyte3_access  is access all nbyte3;
   type nbyte4_access  is access all nbyte4;
   type nbyte8_access  is access all nbyte8;
   type byte1_access   is access all byte1;
   type byte2_access   is access all byte2;
   type byte3_access   is access all byte3;
   type byte4_access   is access all byte4;
   type byte8_access   is access all byte8;
   type real9_access   is access all real9;
   type real18_access  is access all real18;
   type str1_access    is access all textual;
   type str2_access    is access all textwide;
   type str4_access    is access all textsuper;
   type time_access    is access all AC.Time;
   type chain_access   is access all chain;     --  stored as access
   type enum_access    is access all enumtype;
   type settype_access is access all settype;   --  stored as access

   ------------------------------------------------
   --  CONSTANTS FOR PARAMETER TYPE DEFINITIONS  --
   ------------------------------------------------
   PARAM_IS_BOOLEAN   : constant nbyte0 := False;
   PARAM_IS_NBYTE_1   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_2   : constant nbyte2 := 0;
   PARAM_IS_NBYTE_3   : constant nbyte3 := 0;
   PARAM_IS_NBYTE_4   : constant nbyte4 := 0;
   PARAM_IS_NBYTE_8   : constant nbyte8 := 0;
   PARAM_IS_BYTE_1    : constant byte1 := 0;
   PARAM_IS_BYTE_2    : constant byte2 := 0;
   PARAM_IS_BYTE_3    : constant byte3 := 0;
   PARAM_IS_BYTE_4    : constant byte4 := 0;
   PARAM_IS_BYTE_8    : constant byte8 := 0;
   PARAM_IS_REAL_9    : constant real9  := 0.0;
   PARAM_IS_REAL_18   : constant real18 := 0.0;
   PARAM_IS_CHAIN     : constant chain := (1 .. 1 => 0);
   PARAM_IS_ENUM      : constant enumtype := (CT.blank, 0);
   PARAM_IS_SET       : constant settype := (1 .. 1 => (CT.blank, 0));
   PARAM_IS_TEXTUAL   : constant textual := CT.blank;
   PARAM_IS_TEXTWIDE  : constant textwide := SUW.Null_Unbounded_Wide_String;
   PARAM_IS_TEXTSUPER : constant textsuper :=
                       SUWW.Null_Unbounded_Wide_Wide_String;
   PARAM_IS_TIMESTAMP : constant AC.Time := AC.Time_Of (AC.Year_Number'First,
                                                        AC.Month_Number'First,
                                                        AC.Day_Number'First);

end AdaBase.Results;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../../License.txt

with CommonText;
with Ada.Calendar;
with Ada.Strings.Wide_Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;

package AdaBase.Results is

   package CT   renames CommonText;
   package AC   renames Ada.Calendar;
   package SUW  renames Ada.Strings.Wide_Unbounded;
   package SUWW renames Ada.Strings.Wide_Wide_Unbounded;

   subtype textual   is CT.Text;
   subtype textwide  is SUW.Unbounded_Wide_String;
   subtype textsuper is SUWW.Unbounded_Wide_Wide_String;

   TARGET_TYPE_TOO_NARROW : exception;
   CONVERSION_FAILED      : exception;
   UNSUPPORTED_CONVERSION : exception;
   COLUMN_DOES_NOT_EXIST  : exception;
   CONSTRUCTOR_DO_NOT_USE : exception;

   -------------------------------------------
   --  Supported Field Types (Standardized) --
   -------------------------------------------

   type nbyte1 is mod 2 ** 8;
   type nbyte2 is mod 2 ** 16;
   type nbyte3 is mod 2 ** 24;
   type nbyte4 is mod 2 ** 32;
   type nbyte8 is mod 2 ** 64;
   type byte8  is range -2 ** 63 .. 2 ** 63 - 1;
   type byte4  is range -2 ** 31 .. 2 ** 31 - 1;
   type byte3  is range -2 ** 23 .. 2 ** 23 - 1;
   type byte2  is range -2 ** 15 .. 2 ** 15 - 1;
   type byte1  is range -2 **  7 .. 2 **  7 - 1;
   type real9  is digits 9;
   type real18 is digits 18;

   subtype nbyte0 is Boolean;

   type enumtype is record
      enumeration : textual;
      index       : Natural;
   end record;
   type settype is array (Positive range <>) of enumtype;
   type chain is array (Positive range <>) of nbyte1;

   type nbyte0_access  is access all nbyte0;
   type nbyte1_access  is access all nbyte1;
   type nbyte2_access  is access all nbyte2;
   type nbyte3_access  is access all nbyte3;
   type nbyte4_access  is access all nbyte4;
   type nbyte8_access  is access all nbyte8;
   type byte1_access   is access all byte1;
   type byte2_access   is access all byte2;
   type byte3_access   is access all byte3;
   type byte4_access   is access all byte4;
   type byte8_access   is access all byte8;
   type real9_access   is access all real9;
   type real18_access  is access all real18;
   type str1_access    is access all textual;
   type str2_access    is access all textwide;
   type str4_access    is access all textsuper;
   type time_access    is access all AC.Time;
   type chain_access   is access all chain;     --  stored as access
   type enum_access    is access all enumtype;
   type settype_access is access all settype;   --  stored as access

   blank_string   : constant textual   := CT.blank;
   blank_wstring  : constant textwide  := SUW.Null_Unbounded_Wide_String;
   blank_wwstring : constant textsuper :=
                       SUWW.Null_Unbounded_Wide_Wide_String;

   ------------------------------------------------
   --  CONSTANTS FOR PARAMETER TYPE DEFINITIONS  --
   ------------------------------------------------
   PARAM_IS_BOOLEAN   : constant nbyte0 := False;
   PARAM_IS_NBYTE_1   : constant nbyte1 := 0;
   PARAM_IS_NBYTE_2   : constant nbyte2 := 0;
   PARAM_IS_NBYTE_3   : constant nbyte3 := 0;
   PARAM_IS_NBYTE_4   : constant nbyte4 := 0;
   PARAM_IS_NBYTE_8   : constant nbyte8 := 0;
   PARAM_IS_BYTE_1    : constant byte1 := 0;
   PARAM_IS_BYTE_2    : constant byte2 := 0;
   PARAM_IS_BYTE_3    : constant byte3 := 0;
   PARAM_IS_BYTE_4    : constant byte4 := 0;
   PARAM_IS_BYTE_8    : constant byte8 := 0;
   PARAM_IS_REAL_9    : constant real9  := 0.0;
   PARAM_IS_REAL_18   : constant real18 := 0.0;
   PARAM_IS_CHAIN     : constant chain := (1 .. 1 => 0);
   PARAM_IS_ENUM      : constant enumtype := (CT.blank, 0);
   PARAM_IS_SET       : constant settype := (1 .. 1 => (CT.blank, 0));
   PARAM_IS_TEXTUAL   : constant textual := blank_string;
   PARAM_IS_TEXTWIDE  : constant textwide := blank_wstring;
   PARAM_IS_TEXTSUPER : constant textsuper := blank_wwstring;
   PARAM_IS_TIMESTAMP : constant AC.Time := AC.Time_Of (AC.Year_Number'First,
                                                        AC.Month_Number'First,
                                                        AC.Day_Number'First);

end AdaBase.Results;

Define blank constants variants

Results: Define blank constants variants


-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
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 with private;
   type Manager_Access is access all Manager'Class;

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

   --  Insert the specified property in the list.
   procedure Insert (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 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);

   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.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

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

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 tagged limited record
         Count : Natural := 0;
      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 Value)
                       return Boolean is abstract;

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

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value) is abstract;

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

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in 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 with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   procedure Adjust   (Object : in out Manager);
   procedure Finalize (Object : in out Manager);

end Util.Properties;

-----------------------------------------------------------------------
--  properties -- Generic name/value property management
--  Copyright (C) 2001, 2002, 2003, 2006, 2008, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;
with Ada.Text_IO;
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 with private;
   type Manager_Access is access all Manager'Class;

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

   --  Insert the specified property in the list.
   procedure Insert (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 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);

   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.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

   --  Load the properties from the file.  The file must follow the
   --  definition of Java property files.
   --  Raises NAME_ERROR if the file does not exist.
   procedure Load_Properties (Self : in out Manager'Class;
                              Path : in String);

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

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 tagged limited record
         Count : Natural := 0;
      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 Value)
                       return Boolean is abstract;

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

      procedure Insert (Self : in out Manager; Name : in Value;
                        Item : in Value) is abstract;

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

      --  Remove the property given its name.
      procedure Remove (Self : in out Manager; Name : in 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 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;

Adjust and Finalize are overriding

Adjust and Finalize are overriding


-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 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 body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;

      Result : Date_Record;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-' then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

      else
         raise Constraint_Error with "invalid date";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Result.Year,
                                              Month       => Result.Month,
                                              Day         => Result.Month_Day,
                                              Hour        => 0,
                                              Minute      => 0,
                                              Second      => 0,
                                              Sub_Second  => 0.0);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

-----------------------------------------------------------------------
--  util-dates-iso8601 -- ISO8601 dates
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package body Util.Dates.ISO8601 is

   --  ------------------------------
   --  Parses an ISO8601 date and return it as a calendar time.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      use Ada.Calendar;

      Result : Date_Record;
   begin
      if Date'Length < 4 then
         raise Constraint_Error with "Invalid date";
      end if;
      Result.Year := Year_Number'Value (Date (Date'First .. Date'First + 3));
      if Date'Length = 4 then
         --  ISO8601 date: YYYY
         Result.Month := 1;
         Result.Month_Day := 1;

      elsif Date'Length = 7 and Date (Date'First + 4) = '-' then
         --  ISO8601 date: YYYY-MM
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'Last));
         Result.Month_Day := 1;

      elsif Date'Length = 8 then
         --  ISO8601 date: YYYYMMDD
         Result.Month := Month_Number'Value (Date (Date'First + 4 .. Date'First + 5));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 6 .. Date'First + 7));

      elsif Date'Length >= 9 and then Date (Date'First + 4) = '-'
        and then Date (Date'First + 7) = '-'
      then
         --  ISO8601 date: YYYY-MM-DD
         Result.Month := Month_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Result.Month_Day := Day_Number'Value (Date (Date'First + 8 .. Date'First + 9));

      else
         raise Constraint_Error with "invalid date";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Result.Year,
                                              Month       => Result.Month,
                                              Day         => Result.Month_Day,
                                              Hour        => 0,
                                              Minute      => 0,
                                              Second      => 0,
                                              Sub_Second  => 0.0);
   end Value;

   --  ------------------------------
   --  Return the ISO8601 date.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      D : Date_Record;
   begin
      Split (D, Date);
      return Image (D);
   end Image;

   function Image (Date : in Date_Record) return String is
      To_Char : constant array (0 .. 9) of Character := "0123456789";
      Result  : String (1 .. 10) := "0000-00-00";
   begin
      Result (1) := To_Char (Date.Year / 1000);
      Result (2) := To_Char (Date.Year / 100 mod 10);
      Result (3) := To_Char (Date.Year / 10 mod 10);
      Result (4) := To_Char (Date.Year mod 10);
      Result (6) := To_Char (Date.Month / 10);
      Result (7) := To_Char (Date.Month mod 10);
      Result (9) := To_Char (Date.Month_Day / 10);
      Result (10) := To_Char (Date.Month_Day mod 10);
      return Result;
   end Image;

end Util.Dates.ISO8601;

Fix compilation style warning

Fix compilation style warning


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

with Ada.Containers;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with ADO.Sessions;
with ADO.Parameters;
package ADO.Schemas.Entities is

   No_Entity_Type : exception;

   --  The entity cache maintains a static cache of database entities.
   type Entity_Cache is new ADO.Caches.Cache_Type with private;

   --  Expand the name into a target parameter value to be used in the SQL query.
   --  The Expander can return a T_NULL when a value is not found or
   --  it may also raise some exception.
   overriding
   function Expand (Instance : in out Entity_Cache;
                    Name     : in String) return ADO.Parameters.Parameter;

   --  Find the entity type index associated with the given database table.
   --  Raises the No_Entity_Type exception if no such mapping exist.
   function Find_Entity_Type (Cache : in Entity_Cache;
                              Table : in Class_Mapping_Access) return ADO.Entity_Type;

   --  Find the entity type index associated with the given database table.
   --  Raises the No_Entity_Type exception if no such mapping exist.
   function Find_Entity_Type (Cache : in Entity_Cache;
                              Name  : in Util.Strings.Name_Access) return ADO.Entity_Type;

   --  Initialize the entity cache by reading the database entity table.
   procedure Initialize (Cache   : in out Entity_Cache;
                         Session : in out ADO.Sessions.Session'Class);

private

   package Entity_Map is new
     Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                            Element_Type    => ADO.Entity_Type,
                                            Hash            => Ada.Strings.Hash,
                                            Equivalent_Keys => "=");

   type Entity_Cache is new ADO.Caches.Cache_Type with record
      Entities : Entity_Map.Map;
   end record;

end ADO.Schemas.Entities;

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

with Ada.Containers;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with ADO.Sessions;
with ADO.Parameters;
with ADO.Caches;
package ADO.Schemas.Entities is

   No_Entity_Type : exception;

   --  The entity cache maintains a static cache of database entities.
   type Entity_Cache is new ADO.Caches.Cache_Type with private;

   --  Expand the name into a target parameter value to be used in the SQL query.
   --  The Expander can return a T_NULL when a value is not found or
   --  it may also raise some exception.
   overriding
   function Expand (Instance : in out Entity_Cache;
                    Name     : in String) return ADO.Parameters.Parameter;

   --  Find the entity type index associated with the given database table.
   --  Raises the No_Entity_Type exception if no such mapping exist.
   function Find_Entity_Type (Cache : in Entity_Cache;
                              Table : in Class_Mapping_Access) return ADO.Entity_Type;

   --  Find the entity type index associated with the given database table.
   --  Raises the No_Entity_Type exception if no such mapping exist.
   function Find_Entity_Type (Cache : in Entity_Cache;
                              Name  : in Util.Strings.Name_Access) return ADO.Entity_Type;

   --  Initialize the entity cache by reading the database entity table.
   procedure Initialize (Cache   : in out Entity_Cache;
                         Session : in out ADO.Sessions.Session'Class);

private

   package Entity_Map is new
     Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                            Element_Type    => ADO.Entity_Type,
                                            Hash            => Ada.Strings.Hash,
                                            Equivalent_Keys => "=");

   type Entity_Cache is new ADO.Caches.Cache_Type with record
      Entities : Entity_Map.Map;
   end record;

end ADO.Schemas.Entities;

Add missing with clause ADO.Caches

Add missing with clause ADO.Caches