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

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);

         when MAT.Events.Targets.MSG_REALLOC =>
            return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
              & Addr (Item.Addr);

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

         when others =>
            return "unknown";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Iter : MAT.Events.Targets.Target_Event_Cursor := Related.First;
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Iter : MAT.Events.Targets.Target_Event_Cursor := Related.First;
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  Format a short description of the event.
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

         when others =>
            return "unknown";

      end case;
   end Event;

end MAT.Formats;

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

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Targets.Probe_Event_Type) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);

         when MAT.Events.Targets.MSG_REALLOC =>
            return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
              & Addr (Item.Addr);

         when MAT.Events.Targets.MSG_FREE =>
            return "free(" & Addr (Item.Addr) & ")";

         when MAT.Events.Targets.MSG_BEGIN =>
            return "begin";

         when MAT.Events.Targets.MSG_END =>
            return "end";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Targets.Probe_Event_Type;
                          Related    : in MAT.Events.Targets.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Free_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Targets.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Targets.Probe_Event_Type;
                        Related    : in MAT.Events.Targets.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Targets.Probe_Event_Type;
   begin
      Alloc_Event := MAT.Events.Targets.Find (Related, MAT.Events.Targets.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Targets.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Targets.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Targets.Probe_Event_Type;
                   Related    : in MAT.Events.Targets.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.Targets.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.Targets.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.Targets.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.Targets.MSG_END =>
            return "End event";

         when MAT.Events.Targets.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Fix compilation warnings

Fix compilation warnings


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

with ADO.Sequences.Hilo;
with Ada.Unchecked_Deallocation;

--  The <b>ADO.Sessions.Factory</b> package defines the factory for creating
--  sessions.
package body ADO.Sessions.Factory is

   use ADO.Databases;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Proxy_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      if Proxy.Session = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy.Session;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
--        if Proxy.Session = null then
--           raise ADO.Objects.SESSION_EXPIRED;
--        end if;
      R.Impl := Proxy;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Databases.DataSource) is
   begin
      Factory.Source := Source;
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

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

with ADO.Sequences.Hilo;
with Ada.Unchecked_Deallocation;

--  The <b>ADO.Sessions.Factory</b> package defines the factory for creating
--  sessions.
package body ADO.Sessions.Factory is

   use ADO.Databases;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Proxy_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      if Proxy.Session = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy.Session;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
--        if Proxy.Session = null then
--           raise ADO.Objects.SESSION_EXPIRED;
--        end if;
      R.Impl := Proxy;
      R.Impl.Counter := R.Impl.Counter + 1;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
      S  : constant Session_Record_Access   := new Session_Record;
   begin
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Databases.DataSource) is
   begin
      Factory.Source := Source;
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := Factory.Entity_Cache'Unchecked_Access;
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entity_Cache, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

Fix possible memory leak if the connection cannot be obtained: create the Session_Record only after having created the database connection.


-----------------------------------------------------------------------
--  factory -- Session Factory
--  Copyright (C) 2009, 2010, 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 ADO.Sequences.Hilo;

--  The <b>ADO.Sessions.Factory</b> package defines the factory for creating
--  sessions.
package body ADO.Sessions.Factory is

   use ADO.Databases;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
   begin
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy;
      Util.Concurrent.Counters.Increment (R.Impl.Counter);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      DB : constant Master_Connection'Class := Factory.Source.Get_Connection;
      S  : constant Session_Record_Access   := new Session_Record;
   begin
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      S.Database := Master_Connection (DB);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Databases.DataSource) is
   begin
      Factory.Source := Source;
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

-----------------------------------------------------------------------
--  factory -- Session Factory
--  Copyright (C) 2009, 2010, 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 ADO.Sequences.Hilo;

package body ADO.Sessions.Factory is

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory  : in out Session_Factory;
                           Database : out Session) is
      S  : constant Session_Record_Access := new Session_Record;
   begin
      Factory.Source.Create_Connection (S.Database);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      Database.Impl := S;
   end Open_Session;

   --  ------------------------------
   --  Get a read-only session from the factory.
   --  ------------------------------
   function Get_Session (Factory : in Session_Factory) return Session is
      R  : Session;
      S  : constant Session_Record_Access := new Session_Record;
   begin
      Factory.Source.Create_Connection (S.Database);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      R.Impl := S;
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-only session from the session proxy.
   --  If the session has been invalidated, raise the SESSION_EXPIRED exception.
   --  ------------------------------
   function Get_Session (Proxy : in Session_Record_Access) return Session is
      R : Session;
   begin
      if Proxy = null then
         raise ADO.Objects.SESSION_EXPIRED;
      end if;
      R.Impl := Proxy;
      Util.Concurrent.Counters.Increment (R.Impl.Counter);
      return R;
   end Get_Session;

   --  ------------------------------
   --  Get a read-write session from the factory.
   --  ------------------------------
   function Get_Master_Session (Factory : in Session_Factory) return Master_Session is
      R  : Master_Session;
      S  : constant Session_Record_Access   := new Session_Record;
   begin
      R.Impl := S;
      R.Sequences := Factory.Sequences;
      Factory.Source.Create_Connection (S.Database);
      S.Entities := Factory.Entities;
      S.Values   := Factory.Cache_Values;
      return R;
   end Get_Master_Session;

   --  ------------------------------
   --  Open a session
   --  ------------------------------
   procedure Open_Session (Factory : in Session_Factory;
                           Database : out Master_Session) is
   begin
      null;
   end Open_Session;

   --  ------------------------------
   --  Initialize the sequence factory associated with the session factory.
   --  ------------------------------
   procedure Initialize_Sequences (Factory : in out Session_Factory) is
      use ADO.Sequences;
   begin
      Factory.Sequences := Factory.Seq_Factory'Unchecked_Access;
      Set_Default_Generator (Factory.Seq_Factory,
                             ADO.Sequences.Hilo.Create_HiLo_Generator'Access,
                             Factory'Unchecked_Access);
   end Initialize_Sequences;

   --  ------------------------------
   --  Create the session factory to connect to the database represented
   --  by the data source.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     Source  : in ADO.Sessions.Sources.Data_Source) is
   begin
      Factory.Source := Source;
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

   --  ------------------------------
   --  Create the session factory to connect to the database identified
   --  by the URI.
   --  ------------------------------
   procedure Create (Factory : out Session_Factory;
                     URI     : in String) is
   begin
      Factory.Source.Set_Connection (URI);
      Factory.Entities := new ADO.Schemas.Entities.Entity_Cache;
      Factory.Cache_Values := Factory.Cache'Unchecked_Access;
      Factory.Cache.Add_Cache (ENTITY_CACHE_NAME, Factory.Entities.all'Access);
      Initialize_Sequences (Factory);

      if Factory.Source.Get_Database /= "" then
         declare
            S : Session := Factory.Get_Session;
         begin
            ADO.Schemas.Entities.Initialize (Factory.Entities.all, S);
         end;
      end if;
   end Create;

end ADO.Sessions.Factory;

Refactor the session management and use the data source types in ADO.Sessions.Sources


-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012, 2015, 2017, 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 Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;
with Ada.Text_IO;

with Gen.Model.Packages;
private with Util.Strings.Maps;

--  with Asis;
--  with Asis.Text;
--  with Asis.Elements;
--  with Asis.Exceptions;
--  with Asis.Errors;
--  with Asis.Implementation;
--  with Asis.Elements;
--  with Asis.Declarations;
--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  Tag marker (same as Java).
   TAG_CHAR     : constant Character := '@';

   --  Specific tags recognized when analyzing the documentation.
   TAG_AUTHOR         : constant String := "author";
   TAG_TITLE          : constant String := "title";
   TAG_INCLUDE        : constant String := "include";
   TAG_INCLUDE_CONFIG : constant String := "include-config";
   TAG_INCLUDE_BEAN   : constant String := "include-bean";
   TAG_INCLUDE_QUERY  : constant String := "include-query";
   TAG_INCLUDE_PERM   : constant String := "include-permission";
   TAG_SEE            : constant String := "see";

   Unknown_Tag : exception;

   type Doc_Format is (DOC_MARKDOWN, DOC_WIKI_GOOGLE);

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Set the output document format to generate.
   procedure Set_Format (Handler : in out Artifact;
                         Format  : in Doc_Format;
                         Footer  : in Boolean);

   --  Load from the file a list of link definitions which can be injected in the generated doc.
   --  This allows to avoid polluting the Ada code with external links.
   procedure Read_Links (Handler : in out Artifact;
                         Path    : in String);

private

   type Line_Kind is (L_TEXT, L_LIST, L_LIST_ITEM, L_SEE, L_INCLUDE, L_INCLUDE_CONFIG,
                      L_INCLUDE_BEAN, L_INCLUDE_PERMISSION, L_INCLUDE_QUERY,
                      L_START_CODE, L_END_CODE,
                      L_HEADER_1, L_HEADER_2, L_HEADER_3, L_HEADER_4);

   subtype Line_Include_Kind is Line_Kind range L_INCLUDE .. L_INCLUDE_QUERY;

   type Line_Type (Len : Natural) is record
      Kind    : Line_Kind := L_TEXT;
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Line_Group_Vector is array (Line_Include_Kind) of Line_Vectors.Vector;

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type Document_Formatter is abstract tagged record
      Links : Util.Strings.Maps.Map;
   end record;
   type Document_Formatter_Access is access all Document_Formatter'Class;

   type File_Document is record
      Name         : Ada.Strings.Unbounded.Unbounded_String;
      Title        : Ada.Strings.Unbounded.Unbounded_String;
      State        : Doc_State := IN_PARA;
      Line_Number  : Natural := 0;
      Lines        : Line_Group_Vector;
      Was_Included : Boolean := False;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is abstract;

   --  Start a new document.
   procedure Start_Document (Formatter : in out Document_Formatter;
                             Document  : in File_Document;
                             File      : in Ada.Text_IO.File_Type) is abstract;

   --  Write a line in the target document formatting the line if necessary.
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is abstract;

   --  Finish the document.
   procedure Finish_Document (Formatter : in out Document_Formatter;
                              Document  : in File_Document;
                              File      : in Ada.Text_IO.File_Type;
                              Source    : in String) is abstract;

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

   --  Include the document extract represented by Name into the document Into.
   --  The included document is marked so that it will not be generated.
   procedure Include (Docs     : in out Doc_Maps.Map;
                      Into     : in out File_Document;
                      Name     : in String;
                      Mode     : in Line_Include_Kind;
                      Position : in Natural);

   --  Generate the project documentation that was collected in Docs.
   --  The documentation is merged so that the @include tags are replaced by the matching
   --  document extracts.
   procedure Generate (Docs : in out Doc_Maps.Map;
                       Dir  : in String);

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Look and analyze the tag defined on the line.
   procedure Append_Tag (Doc : in out File_Document;
                         Tag : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Set the title associated with the document extract.
   procedure Set_Title (Doc   : in out File_Document;
                        Title : in String);

   --  Scan the files in the directory refered to by Path and collect the documentation
   --  in the Docs hashed map.
   procedure Scan_Files (Handler : in out Artifact;
                         Path    : in String;
                         Docs    : in out Doc_Maps.Map);

   --  Read the Ada specification/body file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   procedure Read_Xml_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      Xslt_Command : Ada.Strings.Unbounded.Unbounded_String;
      Format       : Doc_Format := DOC_WIKI_GOOGLE;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

end Gen.Artifacts.Docs;

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

with Gen.Model.Packages;
private with Util.Strings.Maps;

--  with Asis;
--  with Asis.Text;
--  with Asis.Elements;
--  with Asis.Exceptions;
--  with Asis.Errors;
--  with Asis.Implementation;
--  with Asis.Elements;
--  with Asis.Declarations;
--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  Tag marker (same as Java).
   TAG_CHAR     : constant Character := '@';

   --  Specific tags recognized when analyzing the documentation.
   TAG_AUTHOR         : constant String := "author";
   TAG_TITLE          : constant String := "title";
   TAG_INCLUDE        : constant String := "include";
   TAG_INCLUDE_CONFIG : constant String := "include-config";
   TAG_INCLUDE_BEAN   : constant String := "include-bean";
   TAG_INCLUDE_QUERY  : constant String := "include-query";
   TAG_INCLUDE_PERM   : constant String := "include-permission";
   TAG_INCLUDE_DOC    : constant String := "include-doc";
   TAG_SEE            : constant String := "see";

   Unknown_Tag : exception;

   type Doc_Format is (DOC_MARKDOWN, DOC_WIKI_GOOGLE);

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Set the output document format to generate.
   procedure Set_Format (Handler : in out Artifact;
                         Format  : in Doc_Format;
                         Footer  : in Boolean);

   --  Load from the file a list of link definitions which can be injected in the generated doc.
   --  This allows to avoid polluting the Ada code with external links.
   procedure Read_Links (Handler : in out Artifact;
                         Path    : in String);

private

   type Line_Kind is (L_TEXT, L_LIST, L_LIST_ITEM, L_SEE, L_INCLUDE, L_INCLUDE_CONFIG,
                      L_INCLUDE_BEAN, L_INCLUDE_PERMISSION, L_INCLUDE_QUERY,
                      L_INCLUDE_DOC,
                      L_START_CODE, L_END_CODE,
                      L_HEADER_1, L_HEADER_2, L_HEADER_3, L_HEADER_4);

   subtype Line_Include_Kind is Line_Kind range L_INCLUDE .. L_INCLUDE_QUERY;

   type Line_Type (Len : Natural) is record
      Kind    : Line_Kind := L_TEXT;
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Line_Group_Vector is array (Line_Include_Kind) of Line_Vectors.Vector;

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type Document_Formatter is abstract tagged record
      Links : Util.Strings.Maps.Map;
   end record;
   type Document_Formatter_Access is access all Document_Formatter'Class;

   type File_Document is record
      Name         : Ada.Strings.Unbounded.Unbounded_String;
      Title        : Ada.Strings.Unbounded.Unbounded_String;
      State        : Doc_State := IN_PARA;
      Line_Number  : Natural := 0;
      Lines        : Line_Group_Vector;
      Was_Included : Boolean := False;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

   --  Get the document name from the file document (ex: <name>.wiki or <name>.md).
   function Get_Document_Name (Formatter : in Document_Formatter;
                               Document  : in File_Document) return String is abstract;

   --  Start a new document.
   procedure Start_Document (Formatter : in out Document_Formatter;
                             Document  : in File_Document;
                             File      : in Ada.Text_IO.File_Type) is abstract;

   --  Write a line in the target document formatting the line if necessary.
   procedure Write_Line (Formatter : in out Document_Formatter;
                         File      : in Ada.Text_IO.File_Type;
                         Line      : in Line_Type) is abstract;

   --  Finish the document.
   procedure Finish_Document (Formatter : in out Document_Formatter;
                              Document  : in File_Document;
                              File      : in Ada.Text_IO.File_Type;
                              Source    : in String) is abstract;

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

   --  Include the document extract represented by Name into the document Into.
   --  The included document is marked so that it will not be generated.
   procedure Include (Docs     : in out Doc_Maps.Map;
                      Into     : in out File_Document;
                      Name     : in String;
                      Mode     : in Line_Include_Kind;
                      Position : in Natural);

   procedure Include (Docs     : in out Doc_Maps.Map;
                      Into     : in out File_Document;
                      Name     : in String;
                      Position : in Natural);

   --  Generate the project documentation that was collected in Docs.
   --  The documentation is merged so that the @include tags are replaced by the matching
   --  document extracts.
   procedure Generate (Docs : in out Doc_Maps.Map;
                       Dir  : in String);

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Look and analyze the tag defined on the line.
   procedure Append_Tag (Doc : in out File_Document;
                         Tag : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Set the title associated with the document extract.
   procedure Set_Title (Doc   : in out File_Document;
                        Title : in String);

   --  Scan the files in the directory refered to by Path and collect the documentation
   --  in the Docs hashed map.
   procedure Scan_Files (Handler : in out Artifact;
                         Path    : in String;
                         Docs    : in out Doc_Maps.Map);

   --  Read the Ada specification/body file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   procedure Read_Xml_File (Handler : in out Artifact;
                            File    : in String;
                            Result  : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      Xslt_Command : Ada.Strings.Unbounded.Unbounded_String;
      Format       : Doc_Format := DOC_WIKI_GOOGLE;
      Print_Footer : Boolean := True;
      Formatter    : Document_Formatter_Access;
   end record;

end Gen.Artifacts.Docs;

Add TAG_INCLUDE_DOC (@include-doc) and procedure Include to handle it


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

with Util.Test_Caller;
with Util.Strings.Transforms;

with ADO.Utils;
with ADO.Sessions;

with Regtests.Statements.Model;
package body ADO.Statements.Tests is

   use Util.Tests;

   procedure Populate (Tst : in out Test);
   function Get_Sum (T     : in Test;
                     Table : in String) return Natural;

   --  Test the query statement Get_Xxx operation for various types.
   generic
      type T (<>) is private;
      with function Get_Value (Stmt   : in ADO.Statements.Query_Statement;
                               Column : in Natural) return T is <>;
      Name   : String;
      Column : String;
   procedure Test_Query_Get_Value_T (Tst   : in out Test);

   procedure Populate (Tst : in out Test) is
      DB    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 10 loop
         declare
            Item : Regtests.Statements.Model.Table_Ref;
         begin
            Item.Set_Id_Value (ADO.Identifier (I * I));
            Item.Set_Int_Value (I);
            Item.Set_Bool_Value ((I mod 2) = 0);
            Item.Set_String_Value ("Item" & Integer'Image (I));
            Item.Set_Time_Value (Ada.Calendar.Clock);
            Item.Set_Entity_Value (ADO.Entity_Type (10 - I));
            Item.Save (DB);
            Tst.Assert (Item.Is_Inserted, "Item inserted in database");
         end;
      end loop;
      DB.Commit;
   end Populate;

   --  ------------------------------
   --  Test the query statement Get_Xxx operation for various types.
   --  ------------------------------
   procedure Test_Query_Get_Value_T (Tst   : in out Test) is
      Stmt : ADO.Statements.Query_Statement;
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
   begin
      Populate (Tst);

      --  Check that Get_Value raises an exception if the statement is invalid.
      begin
         declare
            V    : T := Get_Value (Stmt, 0);
            pragma Unreferenced (V);
         begin
            Util.Tests.Fail (Tst, "No Invalid_Statement exception raised for " & Name);
         end;

      exception
         when Invalid_Statement =>
            null;
      end;

      --  Execute a query to fetch one column.
      Stmt := DB.Create_Statement ("SELECT " & Column & " FROM test_table WHERE id = 1");
      Stmt.Execute;

      --  Verify the query result and the Get_Value operation.
      Tst.Assert (Stmt.Has_Elements, "The query statement must return a value for "
                  & Name & ":" & Column);
      Tst.Assert (not Stmt.Is_Null (0), "The query statement must return a non null value for "
                  & Name & ":" & Column);
      Util.Tests.Assert_Equals (Tst, Column,
                                Util.Strings.Transforms.To_Lower_Case (Stmt.Get_Column_Name (0)),
                                "The query returns an invalid column name");
      declare
         V : T := Get_Value (Stmt, 0);
         pragma Unreferenced (V);
      begin
         Stmt.Clear;
      end;

   end Test_Query_Get_Value_T;

   procedure Test_Query_Get_Int64 is
     new Test_Query_Get_Value_T (Int64, ADO.Statements.Get_Int64, "Get_Int64", "id_value");

   procedure Test_Query_Get_Integer is
     new Test_Query_Get_Value_T (Integer, ADO.Statements.Get_Integer, "Get_Integer", "int_value");

   procedure Test_Query_Get_Nullable_Integer is
     new Test_Query_Get_Value_T (Nullable_Integer, ADO.Statements.Get_Nullable_Integer,
                                 "Get_Nullable_Integer", "int_value");

   procedure Test_Query_Get_Nullable_Entity_Type is
     new Test_Query_Get_Value_T (Nullable_Entity_Type, ADO.Statements.Get_Nullable_Entity_Type,
                                 "Get_Nullable_Entity_Type", "entity_value");

   procedure Test_Query_Get_Natural is
     new Test_Query_Get_Value_T (Natural, ADO.Statements.Get_Natural, "Get_Natural", "int_value");

   procedure Test_Query_Get_Identifier is
     new Test_Query_Get_Value_T (ADO.Identifier, ADO.Statements.Get_Identifier,
                                 "Get_Identifier", "id_value");

   procedure Test_Query_Get_Boolean is
     new Test_Query_Get_Value_T (Boolean, ADO.Statements.Get_Boolean, "Get_Boolean", "bool_value");

   procedure Test_Query_Get_String is
     new Test_Query_Get_Value_T (String, ADO.Statements.Get_String, "Get_String", "string_value");

   package Caller is new Util.Test_Caller (Test, "ADO.Statements");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Statements.Save",
                       Test_Save'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Int64",
                       Test_Query_Get_Int64'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Integer",
                       Test_Query_Get_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Nullable_Integer",
                       Test_Query_Get_Nullable_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Natural",
                       Test_Query_Get_Natural'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Identifier",
                       Test_Query_Get_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Boolean",
                       Test_Query_Get_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_String",
                       Test_Query_Get_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Nullable_Entity_Type",
                       Test_Query_Get_Nullable_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Create_Statement (using $entity_type[])",
                       Test_Entity_Types'Access);
   end Add_Tests;

   function Get_Sum (T : in Test;
                     Table : in String) return Natural is
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
      Stmt : ADO.Statements.Query_Statement := DB.Create_Statement ("SELECT SUM(id_value) FROM "
                                                                    & Table);
   begin
      Stmt.Execute;
      T.Assert (Stmt.Has_Elements, "The query statement must return a value for table " & Table);
      return Stmt.Get_Integer (0);
   end Get_Sum;

   function Get_Sum (T     : in Test;
                     Table : in String;
                     Ids   : in ADO.Utils.Identifier_Vector) return Natural is
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
      Stmt : ADO.Statements.Query_Statement := DB.Create_Statement ("SELECT SUM(id_value) FROM "
                                                                    & Table
                                                                    & " WHERE id IN (:ids)");
   begin
      Stmt.Bind_Param ("ids", Ids);
      Stmt.Execute;
      T.Assert (Stmt.Has_Elements, "The query statement must return a value for table " & Table);
      return Stmt.Get_Integer (0);
   end Get_Sum;

   --  ------------------------------
   --  Test creation of several rows in test_table with different column type.
   --  ------------------------------
   procedure Test_Save (T : in out Test) is
      First  : constant Natural := Get_Sum (T, "test_table");
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      List   : ADO.Utils.Identifier_Vector;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 10 loop
         declare
            Item : Regtests.Statements.Model.Table_Ref;
         begin
            Item.Set_Id_Value (ADO.Identifier (I * I));
            Item.Set_Int_Value (I);
            Item.Set_Bool_Value ((I mod 2) = 0);
            Item.Set_String_Value ("Item" & Integer'Image (I));
            Item.Set_Time_Value (Ada.Calendar.Clock);
            Item.Set_Entity_Value (ADO.Entity_Type (10 - I));
            Item.Save (DB);
            List.Append (Item.Get_Id);
         end;
      end loop;
      DB.Commit;

      Util.Tests.Assert_Equals (T, First + 385, Get_Sum (T, "test_table"),
                                "The SUM query returns an invalid value for test_table");
      Util.Tests.Assert_Equals (T, 385, Get_Sum (T, "test_table", List),
                                "The SUM query returns an invalid value for test_table");
   end Test_Save;

   --  ------------------------------
   --  Test queries using the $entity_type[] cache group.
   --  ------------------------------
   procedure Test_Entity_Types (T : in out Test) is
      DB    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt  : ADO.Statements.Query_Statement;
      Count : Natural := 0;
   begin
      Stmt := DB.Create_Statement ("SELECT name FROM entity_type "
                                   & "WHERE entity_type.id = $entity_type[test_user]");
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Util.Tests.Assert_Equals (T, "test_user", Stmt.Get_String (0), "Invalid query response");
         Count := Count + 1;
         Stmt.Next;
      end loop;
      Util.Tests.Assert_Equals (T, 1, Count, "Query must return one row");
   end Test_Entity_Types;

end ADO.Statements.Tests;

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

with Util.Test_Caller;
with Util.Strings.Transforms;

with ADO.Utils;
with ADO.Sessions;

with Regtests.Statements.Model;
package body ADO.Statements.Tests is

   use Util.Tests;

   procedure Populate (Tst : in out Test);
   function Get_Sum (T     : in Test;
                     Table : in String) return Natural;

   --  Test the query statement Get_Xxx operation for various types.
   generic
      type T (<>) is private;
      with function Get_Value (Stmt   : in ADO.Statements.Query_Statement;
                               Column : in Natural) return T is <>;
      Name   : String;
      Column : String;
   procedure Test_Query_Get_Value_T (Tst   : in out Test);

   procedure Populate (Tst : in out Test) is
      DB    : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 10 loop
         declare
            Item : Regtests.Statements.Model.Table_Ref;
         begin
            Item.Set_Id_Value (ADO.Identifier (I * I));
            Item.Set_Int_Value (I);
            Item.Set_Bool_Value ((I mod 2) = 0);
            Item.Set_String_Value ("Item" & Integer'Image (I));
            Item.Set_Time_Value (Ada.Calendar.Clock);
            Item.Set_Entity_Value (ADO.Entity_Type (10 - I));
            Item.Save (DB);
            Tst.Assert (Item.Is_Inserted, "Item inserted in database");
         end;
      end loop;
      DB.Commit;
   end Populate;

   --  ------------------------------
   --  Test the query statement Get_Xxx operation for various types.
   --  ------------------------------
   procedure Test_Query_Get_Value_T (Tst   : in out Test) is
      Stmt : ADO.Statements.Query_Statement;
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
   begin
      Populate (Tst);

      --  Check that Get_Value raises an exception if the statement is invalid.
      begin
         declare
            V    : T := Get_Value (Stmt, 0);
            pragma Unreferenced (V);
         begin
            Util.Tests.Fail (Tst, "No Invalid_Statement exception raised for " & Name);
         end;

      exception
         when Invalid_Statement =>
            null;
      end;

      --  Execute a query to fetch one column.
      Stmt := DB.Create_Statement ("SELECT " & Column & " FROM test_table WHERE id = 1");
      Stmt.Execute;

      --  Verify the query result and the Get_Value operation.
      Tst.Assert (Stmt.Has_Elements, "The query statement must return a value for "
                  & Name & ":" & Column);
      Tst.Assert (not Stmt.Is_Null (0), "The query statement must return a non null value for "
                  & Name & ":" & Column);
      Util.Tests.Assert_Equals (Tst, Column,
                                Util.Strings.Transforms.To_Lower_Case (Stmt.Get_Column_Name (0)),
                                "The query returns an invalid column name");
      declare
         V : T := Get_Value (Stmt, 0);
         pragma Unreferenced (V);
      begin
         Stmt.Clear;
      end;

   end Test_Query_Get_Value_T;

   procedure Test_Query_Get_Int64 is
     new Test_Query_Get_Value_T (Int64, ADO.Statements.Get_Int64, "Get_Int64", "id_value");

   procedure Test_Query_Get_Integer is
     new Test_Query_Get_Value_T (Integer, ADO.Statements.Get_Integer, "Get_Integer", "int_value");

   procedure Test_Query_Get_Nullable_Integer is
     new Test_Query_Get_Value_T (Nullable_Integer, ADO.Statements.Get_Nullable_Integer,
                                 "Get_Nullable_Integer", "int_value");

   procedure Test_Query_Get_Nullable_Entity_Type is
     new Test_Query_Get_Value_T (Nullable_Entity_Type, ADO.Statements.Get_Nullable_Entity_Type,
                                 "Get_Nullable_Entity_Type", "entity_value");

   procedure Test_Query_Get_Natural is
     new Test_Query_Get_Value_T (Natural, ADO.Statements.Get_Natural, "Get_Natural", "int_value");

   procedure Test_Query_Get_Identifier is
     new Test_Query_Get_Value_T (ADO.Identifier, ADO.Statements.Get_Identifier,
                                 "Get_Identifier", "id_value");

   procedure Test_Query_Get_Boolean is
     new Test_Query_Get_Value_T (Boolean, ADO.Statements.Get_Boolean, "Get_Boolean", "bool_value");

   procedure Test_Query_Get_String is
     new Test_Query_Get_Value_T (String, ADO.Statements.Get_String, "Get_String", "string_value");

   package Caller is new Util.Test_Caller (Test, "ADO.Statements");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Statements.Save",
                       Test_Save'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Int64",
                       Test_Query_Get_Int64'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Integer",
                       Test_Query_Get_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Nullable_Integer",
                       Test_Query_Get_Nullable_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Natural",
                       Test_Query_Get_Natural'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Identifier",
                       Test_Query_Get_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Boolean",
                       Test_Query_Get_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_String",
                       Test_Query_Get_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Get_Nullable_Entity_Type",
                       Test_Query_Get_Nullable_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Statements.Create_Statement (using $entity_type[])",
                       Test_Entity_Types'Access);
   end Add_Tests;

   function Get_Sum (T : in Test;
                     Table : in String) return Natural is
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
      Stmt : ADO.Statements.Query_Statement := DB.Create_Statement ("SELECT SUM(id_value) FROM "
                                                                    & Table);
   begin
      Stmt.Execute;
      T.Assert (Stmt.Has_Elements, "The query statement must return a value for table " & Table);
      return Stmt.Get_Integer (0);
   end Get_Sum;

   function Get_Sum (T     : in Test;
                     Table : in String;
                     Ids   : in ADO.Utils.Identifier_Vector) return Natural is
      DB   : constant ADO.Sessions.Session := Regtests.Get_Database;
      Stmt : ADO.Statements.Query_Statement := DB.Create_Statement ("SELECT SUM(id_value) FROM "
                                                                    & Table
                                                                    & " WHERE id IN (:ids)");
   begin
      Stmt.Bind_Param ("ids", Ids);
      Stmt.Execute;
      T.Assert (Stmt.Has_Elements, "The query statement must return a value for table " & Table);
      return Stmt.Get_Integer (0);
   end Get_Sum;

   --  ------------------------------
   --  Test creation of several rows in test_table with different column type.
   --  ------------------------------
   procedure Test_Save (T : in out Test) is
      First  : constant Natural := Get_Sum (T, "test_table");
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      List   : ADO.Utils.Identifier_Vector;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 10 loop
         declare
            Item : Regtests.Statements.Model.Table_Ref;
         begin
            Item.Set_Id_Value (ADO.Identifier (I * I));
            Item.Set_Int_Value (I);
            Item.Set_Bool_Value ((I mod 2) = 0);
            Item.Set_String_Value ("Item" & Integer'Image (I));
            Item.Set_Time_Value (Ada.Calendar.Clock);
            Item.Set_Entity_Value (ADO.Entity_Type (10 - I));
            Item.Save (DB);
            List.Append (Item.Get_Id);
         end;
      end loop;
      DB.Commit;

      Util.Tests.Assert_Equals (T, First + 385, Get_Sum (T, "test_table"),
                                "The SUM query returns an invalid value for test_table");
      Util.Tests.Assert_Equals (T, 385, Get_Sum (T, "test_table", List),
                                "The SUM query returns an invalid value for test_table");
   end Test_Save;

   --  ------------------------------
   --  Test queries using the $entity_type[] cache group.
   --  ------------------------------
   procedure Test_Entity_Types (T : in out Test) is
      DB    : constant ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt  : ADO.Statements.Query_Statement;
      Count : Natural := 0;
   begin
      Stmt := DB.Create_Statement ("SELECT name FROM entity_type "
                                   & "WHERE entity_type.id = $entity_type[test_user]");
      Stmt.Execute;
      while Stmt.Has_Elements loop
         Util.Tests.Assert_Equals (T, "test_user", Stmt.Get_String (0), "Invalid query response");
         Count := Count + 1;
         Stmt.Next;
      end loop;
      Util.Tests.Assert_Equals (T, 1, Count, "Query must return one row");
   end Test_Entity_Types;

end ADO.Statements.Tests;

Fix compilation warning detected by GNAT 2017


with Ada.Text_IO;
with Ada.Command_Line;

with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Video.Surfaces.Makers;
with SDL.Video.Textures.Makers;

with SDL.Images.IO;
with SDL.Events.Events;
with SDL.Error;

procedure Main is

   Window_Title : constant String := "Hello World!";
   Image_Name   : constant String := "../img/grumpy-cat.png";

   use SDL.Video;
   use type Windows.Window_Flags;
   use type Renderers.Renderer_flags;
   use type SDL.Events.Event_Types;

   Win : Windows.Window;
   Ren : Renderers.Renderer;
   Bmp : Surfaces.Surface;
   Tex : Textures.Texture;

   Event : SDL.Events.Events.Events;
begin
   --  Initialise SDL
   if not SDL.Initialise or not SDL.Images.Initialise then
      Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error,
                            "SDL.Initialise error: " & SDL.Error.Get);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;

   --  Create window
   Windows.Makers.Create (Win,
                          Title    => Window_Title,
                          Position => (100, 100),
                          Size     => (620, 387),
                          Flags    => Windows.Windowed or Windows.Shown);

   --  Create renderer
   Renderers.Makers.Create (Rend   => Ren,
                            Window => Win,
                            Flags  => Renderers.Accelerated or Renderers.Present_V_Sync);

   --  Create image
   SDL.Images.IO.Create (Surface   => Bmp,
                         File_Name => Image_Name);

   --  Create texture
   Textures.Makers.Create (Tex      => Tex,
                           Renderer => Ren,
                           Surface  => Bmp);

   --  Present texture
   Ren.Clear;
   Ren.Copy (Copy_From => Tex);
   Ren.Present;

   --  Event loop
   loop
      SDL.Events.Events.Wait (Event);
      exit when Event.Common.Event_Type = SDL.Events.Quit;
      delay 0.010;
   end loop;

   --  Cleanup
   --  Not needed really when soon out of scope
   Tex.Finalize;
   Ren.Finalize;
   Win.Finalize;

   SDL.Finalise;

end Main;

with Ada.Text_IO;
with Ada.Command_Line;

with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Video.Surfaces.Makers;
with SDL.Video.Textures.Makers;

with SDL.Images.IO;
with SDL.Events.Events;
with SDL.Error;

procedure Main is

   Window_Title : constant String := "Hello World!";
   Image_Name   : constant String := "../img/grumpy-cat.png";

   use SDL.Video;
   use type Windows.Window_Flags;
   use type Renderers.Renderer_flags;
   use type SDL.Events.Event_Types;

   Win : Windows.Window;
   Ren : Renderers.Renderer;
   Bmp : Surfaces.Surface;
   Tex : Textures.Texture;

   Event : SDL.Events.Events.Events;
   Dummy : Boolean;
begin
   --  Initialise SDL
   if not SDL.Initialise or not SDL.Images.Initialise then
      Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error,
                            "SDL.Initialise error: " & SDL.Error.Get);
      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
      return;
   end if;

   --  Create window
   Windows.Makers.Create (Win,
                          Title    => Window_Title,
                          Position => (100, 100),
                          Size     => (620, 387),
                          Flags    => Windows.Shown);

   --  Create renderer
   Renderers.Makers.Create (Rend   => Ren,
                            Window => Win,
                            Flags  => (Renderers.Accelerated or
                                         Renderers.Present_V_Sync));

   --  Create image
   SDL.Images.IO.Create (Surface   => Bmp,
                         File_Name => Image_Name);

   --  Create texture
   Textures.Makers.Create (Tex      => Tex,
                           Renderer => Ren,
                           Surface  => Bmp);

   --  Present texture
   Ren.Clear;
   Ren.Copy (Copy_From => Tex);
   Ren.Present;

   --  Event loop
   --  Exit after 2 seconds
   for I in 1 .. 200 loop
      Dummy := SDL.Events.Events.Poll (Event);
      exit when Event.Common.Event_Type = SDL.Events.Quit;
      delay 0.010;
   end loop;

   --  Cleanup
   --  Not needed really when soon out of scope
   Tex.Finalize;
   Ren.Finalize;
   Win.Finalize;

   SDL.Finalise;

end Main;

Stop after 2 sec. Clean window flags

Ada: Stop after 2 sec. Clean window flags


-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  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 ADO.Objects;
with ADO.Sessions;

with Security.Permissions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
private with Ada.Strings.Unbounded;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   subtype Permission_Index_Array is Security.Permissions.Permission_Index_Array;

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   --  The configuration parameter that defines the list of permissions to grant
   --  to a user when his workspace is created.
   PARAM_PERMISSIONS_LIST : constant String := "permissions_list";

   --  Permission to create a workspace.
   package ACL_Create_Workspace is new Security.Permissions.Definition ("workspace-create");

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Workspace_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the list of permissions for the workspace owner.
   function Get_Owner_Permissions (Manager : in Workspace_Module) return Permission_Index_Array;

   --  Get the workspace module.
   function Get_Workspace_Module return Workspace_Module_Access;

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Create a workspace for the user.
   procedure Create_Workspace (Module    : in Workspace_Module;
                               Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

   --  Add a list of permissions for all the users of the workspace that have the appropriate
   --  role.  Workspace members will be able to access the given database entity for the
   --  specified list of permissions.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             List       : in Security.Permissions.Permission_Index_Array);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;

      --  The list of permissions to grant to a user who creates the workspace.
      Owner_Permissions : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Workspaces.Modules;

-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  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 ADO.Objects;
with ADO.Sessions;

with Security.Permissions;

with ASF.Applications;

with AWA.Modules;
with AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Users.Services;
with AWA.Users.Models;
with AWA.Events;
private with Ada.Strings.Unbounded;

--  == Events ==
--  The *workspaces* module provides several events that are posted when some action are performed.
--
--  === invite-user ===
--  This event is posted when an invitation is created for a user.  The event can be used to
--  send the associated invitation email to the invitee.  The event contains the following
--  attributes:
--
--  key
--  email
--  name
--  message
--  inviter
--
--  === accept-invitation ===
--  This event is posted when an invitation is accepted by a user.
package AWA.Workspaces.Modules is

   subtype Permission_Index_Array is Security.Permissions.Permission_Index_Array;

   Not_Found : exception;

   --  The name under which the module is registered.
   NAME : constant String := "workspaces";

   --  The configuration parameter that defines the list of permissions to grant
   --  to a user when his workspace is created.
   PARAM_PERMISSIONS_LIST : constant String := "permissions_list";

   --  Permission to create a workspace.
   package ACL_Create_Workspace is new Security.Permissions.Definition ("workspace-create");
   package ACL_Invite_User is new Security.Permissions.Definition ("workspace-invite-user");

   package Invite_User_Event is new AWA.Events.Definition (Name => "invite-user");
   package Accept_Invitation_Event is new AWA.Events.Definition (Name => "accept-invitation");

   --  ------------------------------
   --  Module workspaces
   --  ------------------------------
   type Workspace_Module is new AWA.Modules.Module with private;
   type Workspace_Module_Access is access all Workspace_Module'Class;

   --  Initialize the workspaces module.
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Configures the module after its initialization and after having read its XML configuration.
   overriding
   procedure Configure (Plugin : in out Workspace_Module;
                        Props  : in ASF.Applications.Config);

   --  Get the list of permissions for the workspace owner.
   function Get_Owner_Permissions (Manager : in Workspace_Module) return Permission_Index_Array;

   --  Get the workspace module.
   function Get_Workspace_Module return Workspace_Module_Access;

   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Create a workspace for the user.
   procedure Create_Workspace (Module    : in Workspace_Module;
                               Workspace : out AWA.Workspaces.Models.Workspace_Ref);

   --  Load the invitation from the access key and verify that the key is still valid.
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref);

   --  Accept the invitation identified by the access key.
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String);

   --  Send the invitation to the user.
   procedure Send_Invitation (Module : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class);

   --  Delete the member from the workspace.  Remove the invitation if there is one.
   procedure Delete_Member (Module       : in Workspace_Module;
                            Member_Id    : in ADO.Identifier);

   --  Add a list of permissions for all the users of the workspace that have the appropriate
   --  role.  Workspace members will be able to access the given database entity for the
   --  specified list of permissions.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             List       : in Security.Permissions.Permission_Index_Array);

private

   type Workspace_Module is new AWA.Modules.Module with record
      User_Manager : AWA.Users.Services.User_Service_Access;

      --  The list of permissions to grant to a user who creates the workspace.
      Owner_Permissions : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Workspaces.Modules;

Declare the ACL_Invite_User permission

Declare the ACL_Invite_User permission