-----------------------------------------------------------------------
--  akt-commands-list -- List commands to report database information for admin tool
--  Copyright (C) 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 Util.Strings;
with ADO.Sessions;
with ADO.Statements;
with ADO.Schemas;
with ADO.Queries;
with AWA.Commands.Models;
package body AWA.Commands.List is

   procedure List (Command : in out Command_Type;
                   Context : in out Context_Type;
                   Session : in out ADO.Sessions.Master_Session;
                   Query   : in ADO.Queries.Context;
                   Prefix  : in String);

   procedure Database_Summary (Command : in out Command_Type;
                               Context : in out Context_Type;
                               Session : in out ADO.Sessions.Master_Session);

   --  ------------------------------
   --  List some database information.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
   begin
      Command_Drivers.Application_Command_Type (Command).Execute (Name, Args, Context);
   end Execute;

   overriding
   procedure Execute (Command     : in out Command_Type;
                      Application : in out AWA.Applications.Application'Class;
                      Args        : in Argument_List'Class;
                      Context     : in out Context_Type) is
      pragma Unreferenced (Args);

      Session     : ADO.Sessions.Master_Session;
      Query       : ADO.Queries.Context;
   begin
      Application.Load_Bundle (Name   => "commands",
                               Locale => "en",
                               Bundle => Command.Bundle);
      Session := Application.Get_Master_Session;

      if Command.List_Users then
         Query.Set_Query (AWA.Commands.Models.Query_Command_User_List);
         List (Command, Context, Session, Query, "command_user_list_");
      end if;

      if Command.List_Sessions then
         Query.Set_Query (AWA.Commands.Models.Query_Command_Session_List);
         List (Command, Context, Session, Query, "command_session_list_");
      end if;

      if Command.List_Jobs then
         Query.Set_Query (AWA.Commands.Models.Query_Command_Job_List);
         List (Command, Context, Session, Query, "command_job_list_");
      end if;

      if Command.List_Tables then
         Database_Summary (Command, Context, Session);
      end if;
   end Execute;

   procedure List (Command : in out Command_Type;
                   Context : in out Context_Type;
                   Session : in out ADO.Sessions.Master_Session;
                   Query   : in ADO.Queries.Context;
                   Prefix  : in String) is
      function Get_Label (Name : in String) return String;

      function Get_Label (Name : in String) return String is
         Result : constant String := Command.Bundle.Get (Prefix & Name);
      begin
         if Util.Strings.Index (Result, ':') > 0 then
            return Result;
         else
            return Result & ":10";
         end if;
      end Get_Label;

      Statement   : ADO.Statements.Query_Statement;
      Print_Names : Boolean := True;
   begin
      Statement := Session.Create_Statement (Query);
      Statement.Execute;
      while Statement.Has_Elements loop
         if Print_Names then
            Context.Console.Start_Title;
            for I in 1 .. Statement.Get_Column_Count loop
               declare
                  Info : constant String := Get_Label (Statement.Get_Column_Name (I - 1));
                  Pos  : constant Natural := Util.Strings.Index (Info, ':');
               begin
                  Context.Console.Print_Title (Field_Number (I),
                                               Info (Info'First .. Pos - 1),
                                               Natural'Value (Info (Pos + 1 .. Info'Last)));
               end;
            end loop;
            Context.Console.End_Title;
            Print_Names := False;
         end if;
         Context.Console.Start_Row;
         for I in 1 .. Statement.Get_Column_Count loop
            if not Statement.Is_Null (I - 1) then
               Context.Console.Print_Field (Field_Number (I),
                                            Statement.Get_String (I - 1));
            end if;
         end loop;
         Context.Console.End_Row;
         Statement.Next;
      end loop;
   end List;

   procedure Database_Summary (Command : in out Command_Type;
                               Context : in out Context_Type;
                               Session : in out ADO.Sessions.Master_Session) is
      pragma Unreferenced (Command);
      use ADO.Schemas;

      Schema : ADO.Schemas.Schema_Definition;
      Iter   : Table_Cursor;
      Col    : Field_Number := 1;
   begin
      Session.Load_Schema (Schema);

      Context.Console.Start_Title;
      Context.Console.Print_Title (1, "Table", 30);
      Context.Console.Print_Title (2, "  Count", 8);
      Context.Console.Print_Title (3, "", 3);
      Context.Console.Print_Title (4, "Table", 30);
      Context.Console.Print_Title (5, "  Count", 8);
      Context.Console.End_Title;

      --  Dump the database schema using SQL create table forms.
      Iter := Get_Tables (Schema);
      while Has_Element (Iter) loop
         declare
            Table      : constant Table_Definition := Element (Iter);
            Count      : Natural;
            Statement  : ADO.Statements.Query_Statement;
         begin
            if Col = 1 then
               Context.Console.Start_Row;
            end if;
            Context.Console.Print_Field (Col, Get_Name (Table));
            Statement := Session.Create_Statement ("SELECT COUNT(*) FROM " & Get_Name (Table));
            Statement.Execute;
            Count := Statement.Get_Integer (0);
            Context.Console.Print_Field (Col + 1, Count, Consoles.J_RIGHT);
            if Col >= 3 then
               Context.Console.End_Row;
               Col := 1;
            else
               Context.Console.Print_Field (Col + 2, "");
               Col := Col + 3;
            end if;
         end;
         Next (Iter);
      end loop;
      if Col /= 1 then
         Context.Console.End_Row;
      end if;
   end Database_Summary;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   overriding
   procedure Setup (Command : in out Command_Type;
                    Config  : in out GNAT.Command_Line.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Config,
                    Usage  => Command.Get_Name & " [arguments]",
                    Help   => Command.Get_Description);
      Command_Drivers.Application_Command_Type (Command).Setup (Config, Context);
      GC.Define_Switch (Config => Config,
                        Output => Command.List_Users'Access,
                        Switch => "-u",
                        Long_Switch => "--users",
                        Help   => -("List the users"));
      GC.Define_Switch (Config => Config,
                        Output => Command.List_Jobs'Access,
                        Switch => "-j",
                        Long_Switch => "--jobs",
                        Help   => -("List the jobs"));
      GC.Define_Switch (Config => Config,
                        Output => Command.List_Sessions'Access,
                        Switch => "-s",
                        Long_Switch => "--sessions",
                        Help   => -("List the sessions"));
      GC.Define_Switch (Config => Config,
                        Output => Command.List_Tables'Access,
                        Switch => "-t",
                        Long_Switch => "--tables",
                        Help   => -("List the database tables"));
   end Setup;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      null;
   end Help;

begin
   Command_Drivers.Driver.Add_Command ("list",
                                       -("list information"),
                                       Command'Access);
end AWA.Commands.List;

Implement operations to list database information for AWA applications


-----------------------------------------------------------------------
--  util-streams-encoders -- Streams with encoding and decoding capabilities
--  Copyright (C) 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.Encoders.Base64;
package body Util.Streams.Buffered.Encoders is

   --  -----------------------
   --  Initialize the stream to write on the given stream.
   --  An internal buffer is allocated for writing the stream.
   --  -----------------------
   procedure Initialize (Stream  : in out Encoding_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Natural;
                         Format  : in String) is
   begin
      Stream.Initialize (Output, Size);
      Stream.Transform := new Util.Encoders.Base64.Encoder;
   end Initialize;

   --  -----------------------
   --  Close the sink.
   --  -----------------------
   overriding
   procedure Close (Stream : in out Encoding_Stream) is
   begin
      Stream.Flush;
      Stream.Output.Close;
   end Close;

   --  -----------------------
   --  Write the buffer array to the output stream.
   --  -----------------------
   overriding
   procedure Write (Stream : in out Encoding_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array) is
      First_Encoded : Ada.Streams.Stream_Element_Offset := Buffer'First;
      Last_Encoded  : Ada.Streams.Stream_Element_Offset;
      Last_Pos      : Ada.Streams.Stream_Element_Offset;
   begin
      while First_Encoded <= Buffer'Last loop
         Stream.Transform.Transform
           (Data    => Buffer (First_Encoded .. Buffer'Last),
            Into    => Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
            Last    => Last_Pos,
            Encoded => Last_Encoded);
         if Last_Encoded < Buffer'Last then
            Stream.Output.Write (Stream.Buffer (Stream.Buffer'First .. Last_Pos));
            Stream.Write_Pos := Stream.Buffer'First;
         else
            Stream.Write_Pos := Last_Pos + 1;
         end if;
         First_Encoded := Last_Encoded + 1;
      end loop;
   end Write;

   --  -----------------------
   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   --  -----------------------
   overriding
   procedure Flush (Stream : in out Encoding_Stream) is
      Last_Pos : Ada.Streams.Stream_Element_Offset;
   begin
      Stream.Transform.Finish (Stream.Buffer (Stream.Write_Pos .. Stream.Buffer'Last),
                               Last_Pos);
      Stream.Write_Pos := Last_Pos + 1;
      Output_Buffer_Stream (Stream).Flush;
   end Flush;

   --  -----------------------
   --  Flush the stream and release the buffer.
   --  -----------------------
   overriding
   procedure Finalize (Object : in out Encoding_Stream) is
   begin
      null;
   end Finalize;

end Util.Streams.Buffered.Encoders;

Implement the Encoding_Stream operations


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . S T A N D                             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1999-2003, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Set_Get; use Asis.Set_Get;
with A4G.A_Types;  use A4G.A_Types;
with A4G.Contt;    use A4G.Contt;

with Stand;        use Stand;
with Atree;        use Atree;
with Sinfo;        use Sinfo;

package body A4G.Stand is

   --------------------------------
   -- Get_Numeric_Error_Renaming --
   --------------------------------

   function Get_Numeric_Error_Renaming return Asis.Element is
      Result : Asis.Element := Numeric_Error_Template;
   begin
      Set_Encl_Tree         (Result, Get_Current_Tree);
      Set_Enclosing_Context (Result, Get_Current_Cont);
      Set_Obtained          (Result, A_OS_Time);

      return Result;
   end Get_Numeric_Error_Renaming;

   ---------------------------
   -- Is_Standard_Char_Type --
   ---------------------------

   function Is_Standard_Char_Type (N : Node_Id) return Boolean is
      Result   : Boolean := False;
      Type_Ent : Entity_Id;
   begin
      if Sloc (N)  = Standard_Location and then
         Nkind (N) = N_Enumeration_Type_Definition
      then
         Type_Ent := Defining_Identifier (Parent (N));

         if Type_Ent in Standard_Character .. Standard_Wide_Character then
            Result := True;
         end if;

      end if;

      return Result;
   end Is_Standard_Char_Type;

   -------------------------
   -- Standard_Char_Decls --
   -------------------------

   function Standard_Char_Decls
     (Type_Definition : Asis.Type_Definition;
      Implicit        : Boolean := False)
      return Asis.Element_List
   is
      Arg_Node     : constant Node_Id := Node (Type_Definition);
      Rel_Len      : Asis.ASIS_Positive;
      Type_Ent     : Entity_Id;
      Tmp_Template : Element := Char_Literal_Spec_Template;
   begin
      --  Adjusting the template for the artificial character literal
      --  specification:

      Set_Encl_Unit_Id      (Tmp_Template, Encl_Unit_Id (Type_Definition));
      Set_Encl_Tree         (Tmp_Template, Encl_Tree (Type_Definition));
      Set_Node              (Tmp_Template, Arg_Node);
      Set_R_Node            (Tmp_Template, Arg_Node);
      Set_Enclosing_Context (Tmp_Template, Encl_Cont_Id (Type_Definition));
      Set_Obtained          (Tmp_Template, A_OS_Time);
      Set_From_Instance     (Tmp_Template, Is_From_Instance (Type_Definition));
      Set_From_Implicit     (Tmp_Template, Implicit);
      Set_From_Inherited    (Tmp_Template, Implicit);

      if Implicit then
         Set_Special_Case (Tmp_Template, Not_A_Special_Case);
         Set_Node_Field_1 (Tmp_Template, Parent (Arg_Node));
      end if;

      Type_Ent := Defining_Identifier (Parent (Arg_Node));

      while Type_Ent /= Etype (Type_Ent) loop
         Type_Ent := Etype (Type_Ent);
      end loop;

      if Type_Ent = Standard_Character then
         Rel_Len := 256;
      else
         Rel_Len := 65536;
      end if;

      declare
         Result : Asis.Element_List (1 .. Rel_Len) := (others => Tmp_Template);
      begin

         for J in 1 .. Rel_Len loop
            Set_Character_Code (Result (J), Char_Code (J - 1));
         end loop;

         return Result;

      end;

   end Standard_Char_Decls;

   ----------------------
   -- Stand_Char_Image --
   ----------------------

   function Stand_Char_Image (Code : Char_Code) return Wide_String is

      function Hex_Digits (J : Natural) return Wide_String;
      --  converts J into Hex digits string

      function Hex_Digits (J : Natural) return Wide_String is
         Hexd : constant Wide_String := "0123456789abcdef";
      begin

         if J > 16#FF# then
            return Hex_Digits (J / 256) & Hex_Digits (J mod 256);
         else
            return Hexd (J / 16 + 1) & Hexd (J mod 16 + 1);
         end if;

      end Hex_Digits;

   begin

      if Code in 16#20# .. 16#7E# then
         return ''' & Wide_Character'Val (Code) & ''';

      else

         return "'[""" & Hex_Digits (Natural (Code)) & """]'";

      end if;

   end Stand_Char_Image;

end A4G.Stand;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Test_Caller;

package body Util.Mail.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Mail.Parse_Address",
                       Test_Parse_Address'Access);
   end Add_Tests;

   procedure Test_Parse_Address (T : in out Test) is
      use Ada.Strings.Unbounded;

      procedure Check (Value : in String;
                       Name  : in String;
                       Email : in String);
      procedure Check (Value : in String;
                       Name  : in String;
                       Email : in String) is
         A : constant Email_Address := Parse_Address (Value);
      begin
         Util.Tests.Assert_Equals (T, Name, To_String (A.Name),
                                   "Invalid name for: " & Value);
         Util.Tests.Assert_Equals (T, Email, To_String (A.Address),
                                   "Invalid email for: " & Value);
      end Check;

   begin
      Check ("Luke Jedi <Luke@skywalker.universe> ", "Luke Jedi", "Luke@skywalker.universe");
      Check (" <Anakin@skywalker.universe> ", "Anakin", "Anakin@skywalker.universe");
      Check (" Vador@skywalker.universe ", "Vador", "Vador@skywalker.universe");
   end Test_Parse_Address;

end Util.Mail.Tests;

Implement new unit test for Parse_Address


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

with Util.Beans.Basic;
with Util.Beans.Objects.Lists;

with ADO;
with ADO.Schemas;
with ADO.Sessions;

with AWA.Comments.Models;
with AWA.Comments.Modules;

--  == Comment Beans ==
--  Several bean types are provided to represent and manage a list of tags.
--  The tag module registers the bean constructors when it is initialized.
--  To use them, one must declare a bean definition in the application XML configuration.
--
--  === Comment_List_Bean ===
--  The <tt>Comment_List_Bean</tt> holds a list of comments and provides operations used by the
--  <tt>awa:tagList</tt> component to add or remove tags within a <tt>h:form</tt> component.
--  A bean can be declared and configured as follows in the XML application configuration file:
--
--    <managed-bean>
--      <managed-bean-name>postCommentList</managed-bean-name>
--      <managed-bean-class>AWA.Comments.Beans.Comment_List_Bean</managed-bean-class>
--      <managed-bean-scope>request</managed-bean-scope>
--      <managed-property>
--        <property-name>entity_type</property-name>
--        <property-class>String</property-class>
--        <value>awa_post</value>
--      </managed-property>
--      <managed-property>
--        <property-name>permission</property-name>
--        <property-class>String</property-class>
--        <value>blog-comment-post</value>
--      </managed-property>
--    </managed-bean>
--
--  The <tt>entity_type</tt> property defines the name of the database table to which the comments
--  are assigned.  The <tt>permission</tt> property defines the permission name that must be used
--  to verify that the user has the permission do add or remove the comment.
--
package AWA.Comments.Beans is

   type Comment_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with private;

   type Comment_List_Bean_Access is access all Comment_List_Bean'Class;

   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Set the entity type (database table) with which the comments are associated.
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access);

   --  Set the permission to check before removing or adding a comment on the entity.
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String);

   --  Load the comments associated with the given database identifier.
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier);

   --  Create the comment list bean instance.
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                  return Util.Beans.Basic.Readonly_Bean_Access;

private

   type Comment_List_Bean is
     new Util.Beans.Objects.Lists.List_Bean and Util.Beans.Basic.Bean with record
      Module      : AWA.Comments.Modules.Comment_Module_Access;
      Entity_Type : Ada.Strings.Unbounded.Unbounded_String;
      Permission  : Ada.Strings.Unbounded.Unbounded_String;
      Current     : Natural := 0;
   end record;

end AWA.Comments.Beans;

Define the Comment_List_Bean type to represent a list of comments to be displayed


-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 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.Log.Loggers;
package body Util.Commands.Drivers is

   --  The logger
   Logs : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create (Driver_Name);

   --  ------------------------------
   --  Write the command usage.
   --  ------------------------------
   procedure Usage (Command : in Command_Type) is
   begin
      null;
   end Usage;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   --  ------------------------------
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Command.Driver.Log (Level, Name, Message);
   end Log;

   --  ------------------------------
    --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access) is
   begin
      Command.Driver := Driver'Unchecked_Access;
      Driver.List.Include (Name, Command);
   end Add_Command;

   --  ------------------------------
   --  Register the command under the given name.
   --  ------------------------------
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Handler : in Command_Handler) is
   begin
      Driver.List.Include (Name, new Handler_Command_Type '(Driver  => Driver'Unchecked_Access,
                                                            Handler => Handler));
   end Add_Command;

   --  ------------------------------
   --  Find the command having the given name.
   --  Returns null if the command was not found.
   --  ------------------------------
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access is
      Pos : constant Command_Maps.Cursor := Driver.List.Find (Name);
   begin
      if Command_Maps.Has_Element (Pos) then
         return Command_Maps.Element (Pos);
      else
         return null;
      end if;
   end Find_Command;

   --  ------------------------------
   --  Execute the command registered under the given name.
   --  ------------------------------
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in out Argument_List;
                      Context : in out Context_Type) is
      Command : constant Command_Access := Driver.Find_Command (Name);
   begin
      if Command /= null then
         Command.Execute (Name, Args, Context);
      end if;
   end Execute;

   --  ------------------------------
   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  ------------------------------
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String) is
   begin
      Logs.Print (Level, "{0}: {1}", Name, Message);
   end Log;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Handler_Command_Type;
                      Name      : in String;
                      Args      : in out Argument_List;
                      Context   : in out Context_Type) is
   begin
      Command.Handler (Name, Args, Context);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Handler_Command_Type;
                   Context   : in out Context_Type) is
   begin
      null;
   end Help;

end Util.Commands.Drivers;

Implement the generic package

Implement the generic package


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . K N D _ C O N V                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 15351 $
--                                                                          --
--            Copyright (c) 1995-2002, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General  --
-- Public License for more details. You should have received a copy of the  --
-- GNU General Public License  distributed with ASIS-for-GNAT; see file     --
-- COPYING. If not, write to the Free Software Foundation,  59 Temple Place --
-- - Suite 330,  Boston, MA 02111-1307, USA.                                --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  Ada Core Technologies Inc --
-- (http://www.gnat.com).                                                   --
--                                                                          --
------------------------------------------------------------------------------

with Asis.Set_Get;
with A4G.Knd_Conv; use A4G.Knd_Conv;
with A4G.Vcheck;   use A4G.Vcheck;

package body Asis.Extensions.Flat_Kinds is

   use Asis;

   -----------------------
   -- Flat_Element_Kind --
   -----------------------

   function Flat_Element_Kind
     (Element : Asis.Element)
      return    Flat_Element_Kinds
   is
   begin
      Check_Validity (Element, "Asis.Extensions.Flat_Kinds.Flat_Element_Kind");

      return Flat_Element_Kinds (Asis.Set_Get.Int_Kind (Element));
   end Flat_Element_Kind;

   -------------------------------------------------
   -- Flat Element Kinds Conversion Functions --
   -------------------------------------------------

   function Asis_From_Flat_Kind
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Element_Kinds
   is
   begin
      return Asis_From_Internal_Kind (Internal_Element_Kinds (Flat_Kind));
   end Asis_From_Flat_Kind;

   function Pragma_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Pragma_Kinds
   is
   begin
      return Pragma_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Pragma_Kind_From_Flat;

   function Defining_Name_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Defining_Name_Kinds
   is
   begin
      return Defining_Name_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Defining_Name_Kind_From_Flat;

   function Declaration_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Declaration_Kinds
   is
   begin
      return Declaration_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Declaration_Kind_From_Flat;

   function Definition_Kind_From_Flat
      (Flat_Kind : Flat_Element_Kinds)
       return      Asis.Definition_Kinds
   is
   begin
      return Definition_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Definition_Kind_From_Flat;

   function Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Type_Kinds
   is
   begin
      return Type_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Type_Kind_From_Flat;

   function Formal_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Formal_Type_Kinds
   is
   begin
      return Formal_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Formal_Type_Kind_From_Flat;

   function Access_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Access_Type_Kinds
   is
   begin
      return Access_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Access_Type_Kind_From_Flat;

   function Root_Type_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Root_Type_Kinds
   is
   begin
      return Root_Type_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Root_Type_Kind_From_Flat;

   function Constraint_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Constraint_Kinds
   is
   begin
      return Constraint_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Constraint_Kind_From_Flat;

   function Discrete_Range_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Discrete_Range_Kinds
   is
   begin
      return Discrete_Range_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Discrete_Range_Kind_From_Flat;

   function Expression_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Expression_Kinds
   is
   begin
      return Expression_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Expression_Kind_From_Flat;

   function Operator_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Operator_Kinds
   is
   begin
      return Operator_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Operator_Kind_From_Flat;

   function Attribute_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Attribute_Kinds
   is
   begin
      return Attribute_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Attribute_Kind_From_Flat;

   function Association_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Association_Kinds
   is
   begin
      return Association_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Association_Kind_From_Flat;

   function Statement_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Statement_Kinds
   is
   begin
      return Statement_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Statement_Kind_From_Flat;

   function Path_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Path_Kinds
   is
   begin
      return Path_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Path_Kind_From_Flat;

   function Clause_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Clause_Kinds
   is
   begin
      return Clause_Kind_From_Internal (Internal_Element_Kinds (Flat_Kind));
   end Clause_Kind_From_Flat;

   function Representation_Clause_Kind_From_Flat
     (Flat_Kind : Flat_Element_Kinds)
      return      Asis.Representation_Clause_Kinds
   is
   begin
      return Representation_Clause_Kind_From_Internal
        (Internal_Element_Kinds (Flat_Kind));
   end Representation_Clause_Kind_From_Flat;

   -------------------------------------
   -- Additional Classification items --
   -------------------------------------

   -----------------------
   -- Def_Operator_Kind --
   -----------------------

   function Def_Operator_Kind
     (Op_Kind : Flat_Element_Kinds)
      return    Flat_Element_Kinds
   is
   begin
      return Flat_Element_Kinds (Def_Operator_Kind
               (Internal_Element_Kinds (Op_Kind)));
   end Def_Operator_Kind;

end Asis.Extensions.Flat_Kinds;

Add the ASIS file $i

Add the ASIS file $i


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

with Util.Tests;

package Security.OAuth.Clients.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test Create_Nonce operation.
   procedure Test_Create_Nonce (T : in out Test);

end Security.OAuth.Clients.Tests;

Add OAuth client unit tests

Add OAuth client unit tests


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

with EL.Methods.Proc_In;

package ASF.Parts.Upload_Method is
  new EL.Methods.Proc_In (Param1_Type => ASF.Parts.Part'Class);

Define a method and binding for an Ada bean to receive an uploaded file


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

   use Ada.Characters.Handling;
   use Ada.Strings;

   function Is_Mime (Header : in String;
                     Mime   : in String) return Boolean is
      Sep : Natural;
   begin
      Sep := Util.Strings.Index (Header, ';');
      if Sep = 0 then
         Sep := Header'Last;
      else
         Sep := Sep - 1;
         while Sep > Header'First and then Is_Space (Header (Sep)) loop
            Sep := Sep - 1;
         end loop;
      end if;
      return Equal_Case_Insensitive (Header (Header'First .. Sep), Mime);
   end Is_Mime;

end Util.Http.Mimes;

Implement Is_Mime function

Implement Is_Mime function


pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL).                                                      --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program is Free Software: You can redistribute it and/or modify    --
--  it under the terms of The GNU General Public License as published by    --
--    the Free Software Foundation: either version 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program is distributed in the hope that it will be useful,     --
--      but WITHOUT ANY WARRANTY; without even the implied warranty of      --
--      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the        --
--              GNU General Public License for more details.                --
--                                                                          --
--    You should have received a copy of the GNU General Public License     --
--   along with this program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
------------------------------------------------------------------------------
with Imago.IL;
use Imago;

package Imago.ILU is

  --------------------------------------------------------------------------

                            ---------------
                            -- T Y P E S --
                            ---------------

  --------------------------------------------------------------------------

  -- TODO: Bind types (ILinfo, ILpointf, ILpointi).

  --------------------------------------------------------------------------

                        -----------------------
                        -- C O N S T A N T S --
                        -----------------------

  --------------------------------------------------------------------------

  ILU_VERSION_1_7_8                     : constant IL.Enum := 1;
  ILU_VERSION                           : constant IL.Enum := 178;

  ILU_FILTER                            : constant IL.Enum := 16#2600#;
  ILU_NEAREST                           : constant IL.Enum := 16#2601#;
  ILU_LINEAR                            : constant IL.Enum := 16#2602#;
  ILU_BILINEAR                          : constant IL.Enum := 16#2603#;
  ILU_SCALE_BOX                         : constant IL.Enum := 16#2604#;
  ILU_SCALE_TRIANGLE                    : constant IL.Enum := 16#2605#;
  ILU_SCALE_BELL                        : constant IL.Enum := 16#2606#;
  ILU_SCALE_BSPLINE                     : constant IL.Enum := 16#2607#;
  ILU_SCALE_LANCZOS3                    : constant IL.Enum := 16#2608#;
  ILU_SCALE_MITCHELL                    : constant IL.Enum := 16#2609#;

  -- Error types.
  ILU_INVALID_ENUM                      : constant IL.Enum := 16#0501#;
  ILU_OUT_OF_MEMORY                     : constant IL.Enum := 16#0502#;
  ILU_INTERNAL_ERROR                    : constant IL.Enum := 16#0504#;
  ILU_INVALID_VALUE                     : constant IL.Enum := 16#0505#;
  ILU_ILLEGAL_OPERATION                 : constant IL.Enum := 16#0506#;
  ILU_INVALID_PARAM                     : constant IL.Enum := 16#0509#;

  -- Values.
  ILU_PLACEMENT                         : constant IL.Enum := 16#0700#;
  ILU_LOWER_LEFT                        : constant IL.Enum := 16#0701#;
  ILU_LOWER_RIGHT                       : constant IL.Enum := 16#0702#;
  ILU_UPPER_LEFT                        : constant IL.Enum := 16#0703#;
  ILU_UPPER_RIGHT                       : constant IL.Enum := 16#0704#;
  ILU_CENTER                            : constant IL.Enum := 16#0705#;
  ILU_CONVOLUTION_MATRIX                : constant IL.Enum := 16#0710#;

  ILU_VERSION_NUM                       : constant IL.Enum := IL.IL_VERSION_NUM;
  ILU_VENDOR                            : constant IL.Enum := IL.IL_VENDOR;

  -- Languages.
  ILU_ENGLISH                           : constant IL.Enum := 16#0800#;
  ILU_ARABIC                            : constant IL.Enum := 16#0801#;
  ILU_DUTCH                             : constant IL.Enum := 16#0802#;
  ILU_JAPANESE                          : constant IL.Enum := 16#0803#;
  ILU_SPANISH                           : constant IL.Enum := 16#0804#;
  ILU_GERMAN                            : constant IL.Enum := 16#0805#;
  ILU_FRENCH                            : constant IL.Enum := 16#0806#;

  --------------------------------------------------------------------------

                        ---------------------------
                        -- S U B P R O G R A M S --
                        ---------------------------

  --------------------------------------------------------------------------

  function Alienify return IL.Bool;
  function Blur_Avg (Iter: in IL.UInt) return IL.Bool;
  function Blur_Gaussian (Iter: in IL.UInt) return IL.Bool;
  function Build_Mipmaps return IL.Bool;
  function Colors_Used return IL.UInt;
  function Colours_Used return IL.UInt;
  function Compare_Image (Comp: in IL.UInt) return IL.Bool;
  function Contrast (Contrats: in Float) return IL.Bool;
  function Crop
    ( XOff: in IL.UInt; YOff: in IL.UInt; ZOff: in IL.UInt;
      Width: in IL.UInt; Height: in IL.UInt; Depth: in IL.UInt
    ) return IL.Bool;
  procedure Delete_Image (ID: in IL.UInt);
  function Edge_Detect_E return IL.Bool;
  function Edge_Detect_P return IL.Bool;
  function Edge_Detect_S return IL.Bool;
  function Emboss return IL.Bool;
  function Enlarge_Canvas
    ( Width: in IL.UInt; Height: in IL.UInt; Depth: in IL.UInt
    ) return IL.Bool;
  function Enlarge_Image
    ( XDim: in Float; YDim: in Float; ZDim: in Float
    ) return IL.Bool;
  function Equalize return IL.Bool;
  function Convolution
    ( Matrix: in IL.Pointer; Scale: in IL.Int; Bias: in IL.Int
    ) return IL.Bool;
  function Flip_Image return IL.Bool;
  function Gamma_Correct (Gamma: in Float) return IL.Bool;
  function Gen_Image return IL.UInt;
  procedure Image_Parameter (P_Name: in IL.Enum; Param: in IL.Enum);
  procedure Init;
  function Invert_Alpha return IL.Bool;
  function Mirror return IL.Bool;
  function Negative return IL.Bool;
  function Noisify (Tolerance: in IL.ClampF) return IL.Bool;
  function Pixelize (Pix_Size: in IL.UInt) return IL.Bool;
  function Replace_Color
    ( Red: in IL.UByte; Green: in IL.UByte;
      Blue: in IL.UByte; Tolerance: in Float
    ) return IL.Bool;
  function Replace_Colour
    ( Red: in IL.UByte; Green: in IL.UByte;
      Blue: in IL.UByte; Tolerance: in Float
    ) return IL.Bool;
  function Scale
    ( Width: in IL.UInt; Height: in IL.UInt; Depth: in IL.UInt
    ) return IL.Bool;
  function Scale_Alpha (Scale: in Float) return IL.Bool;
  function Scale_Colors (R: in Float; G: in Float; B: in Float) return IL.Bool;
  function Scale_Colours (R: in Float; G: in Float; B: in Float) return IL.Bool;
  function Set_Language (Language: in IL.Enum) return IL.Bool;
  function Sharpen (Factor: in Float; Iter: in IL.UInt) return IL.Bool;
  function Swap_Colors return IL.Bool;
  function Swap_Colours return IL.Bool;
  function Wave (Angle: in Float) return IL.Bool;

-- ILconst_string 		 iluErrorString(ILenum Error);
-- void           iluGetImageInfo(ILinfo *Info);
-- ILint          iluGetInteger(ILenum Mode);
-- void           iluGetIntegerv(ILenum Mode, ILint *Param);
-- ILstring 		 iluGetString(ILenum StringName);
-- ILuint         iluLoadImage(ILconst_string FileName);
-- void           iluRegionfv(ILpointf *Points, ILuint n);
-- void           iluRegioniv(ILpointi *Points, ILuint n);
-- ILboolean      iluRotate(ILfloat Angle);
-- ILboolean      iluRotate3D(ILfloat x, ILfloat y, ILfloat z, ILfloat Angle);
-- ILboolean      iluSaturate1f(ILfloat Saturation);
-- ILboolean      iluSaturate4f(ILfloat r, ILfloat g, ILfloat b, ILfloat Saturation);

  --------------------------------------------------------------------------

private

  --------------------------------------------------------------------------

                            -------------------
                            -- I M P O R T S --
                            -------------------

  --------------------------------------------------------------------------

  Pragma Import (StdCall, Alienify, "iluAlienify");
  Pragma Import (StdCall, Blur_Avg, "iluBlurAvg");
  Pragma Import (StdCall, Blur_Gaussian, "iluBlurGaussian");
  Pragma Import (StdCall, Build_Mipmaps, "iluBuildMipmaps");
  Pragma Import (StdCall, Colors_Used, "iluColoursUsed");
  Pragma Import (StdCall, Colours_Used, "iluColoursUsed");
  Pragma Import (StdCall, Compare_Image, "iluCompareImage");
  Pragma Import (StdCall, Contrast, "iluContrast");
  Pragma Import (StdCall, Crop, "iluCrop");
  Pragma Import (StdCall, Delete_Image, "iluDeleteImage");
  Pragma Import (StdCall, Edge_Detect_E, "iluEdgeDetectE");
  Pragma Import (StdCall, Edge_Detect_P, "iluEdgeDetectP");
  Pragma Import (StdCall, Edge_Detect_S, "iluEdgeDetectS");
  Pragma Import (StdCall, Emboss, "iluEmboss");
  Pragma Import (StdCall, Enlarge_Canvas, "iluEnlargeCanvas");
  Pragma Import (StdCall, Enlarge_Image, "iluEnlargeImage");
  Pragma Import (StdCall, Equalize, "iluEqualize");
  Pragma Import (StdCall, Convolution, "iluConvolution");
  Pragma Import (StdCall, Flip_Image, "iluFlipImage");
  Pragma Import (StdCall, Gamma_Correct, "iluGammaCorrect");
  Pragma Import (StdCall, Gen_Image, "iluGenImage");
  Pragma Import (StdCall, Image_Parameter, "iluImageParameter");
  Pragma Import (StdCall, Init, "iluInit");
  Pragma Import (StdCall, Invert_Alpha, "iluInvertAlpha");
  Pragma Import (StdCall, Mirror, "iluMirror");
  Pragma Import (StdCall, Negative, "iluNegative");
  Pragma Import (StdCall, Noisify, "iluNoisify");
  Pragma Import (StdCall, Pixelize, "iluPixelize");
  Pragma Import (StdCall, Replace_Color, "iluReplaceColour");
  Pragma Import (StdCall, Replace_Colour, "iluReplaceColour");
  Pragma Import (StdCall, Scale, "iluScale");
  Pragma Import (StdCall, Scale_Alpha, "iluScaleAlpha");
  Pragma Import (StdCall, Scale_Colors, "iluScaleColours");
  Pragma Import (StdCall, Scale_Colours, "iluScaleColours");
  Pragma Import (StdCall, Set_Language, "iluSetLanguage");
  Pragma Import (StdCall, Sharpen, "iluSharpen");
  Pragma Import (StdCall, Swap_Colors, "iluSwapColours");
  Pragma Import (StdCall, Swap_Colours, "iluSwapColours");
  Pragma Import (StdCall, Wave, "iluWave");

  --------------------------------------------------------------------------

end Imago.ILU;

Add initial bindings to ilu.h.

Add initial bindings to ilu.h.

Signed-off-by: darkestkhan <e9a7a7cf2a6af79e93742343a7a5cac5d90f9bd2@gmail.com>


-----------------------------------------------------------------------
--  awa-tests-helpers - Helpers for AWA unit tests
--  Copyright (C) 2011, 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.
-----------------------------------------------------------------------

package body AWA.Tests.Helpers is

   --  ------------------------------
   --  Extract from the Location header the part that is after the given base string.
   --  If the Location header does not start with the base string, returns the empty
   --  string.
   --  ------------------------------
   function Extract_Redirect (Reply : in ASF.Responses.Mockup.Response'Class;
                              Base  : in String) return String is
      R : constant String := Reply.Get_Header ("Location");
   begin
      if R'Length < Base'Length then
         return "";
      elsif R (R'First .. R'First + Base'Length - 1) /= Base then
         return "";
      else
         return R (R'First + Base'Length .. R'Last);
      end if;
   end Extract_Redirect;

   function Extract_Redirect (Reply : in ASF.Responses.Mockup.Response'Class;
                              Base  : in String) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Ada.Strings.Unbounded.To_Unbounded_String (Extract_Redirect (Reply, Base));
   end Extract_Redirect;

end AWA.Tests.Helpers;

Implement the Extract_Redirect function

Implement the Extract_Redirect function


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

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Votes.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Votes.Modules.Tests is

   use Util.Tests;
   use ADO;

   package Caller is new Util.Test_Caller (Test, "Votes.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Votes.Services.Vote_Up",
                       Test_Vote_Up'Access);
    end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Vote_Up (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      declare
         Vote_Manager : Vote_Module_Access := Get_Vote_Module;
         User         : AWA.Users.Models.User_Ref := Context.Get_User;
      begin
         T.Assert (Vote_Manager /= null, "There is no vote module");

         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 1);
         Vote_Manager.Vote_For (User.Get_Id, "awa_user", "workspaces-create", 2);
      end;
  end Test_Vote_Up;

end AWA.Votes.Modules.Tests;

Update the unit tests

Update the unit tests


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

package body Util.Beans.Objects.Pairs is

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Pair;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "key" or Name = "first" then
         return From.First;
      elsif Name = "value" or Name = "second" then
         return From.Second;
      else
         return Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Pair;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "key" or Name = "first" then
         From.First := Value;
      elsif Name = "value" or Name = "second" then
         From.Second := Value;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Return an object represented by the pair of two values.
   --  ------------------------------
   function To_Object (First, Second : in Object) return Object is
      Result : constant Pair_Access := new Pair;
   begin
      Result.First  := First;
      Result.Second := Second;
      return To_Object (Result.all'Access);
   end To_Object;

end Util.Beans.Objects.Pairs;

Implement pair of objects

Implement pair of objects


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

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in UIComponent'Class) return Views.Nodes.Line_Info is
   begin
      if UI.Tag /= null then
         return UI.Tag.Get_Line_Info;
      else
         return UI.Tag.Get_Line_Info;
      end if;
   end Get_Line_Info;

   --  ------------------------------
   --  Get the line information where the component is defined.
   --  ------------------------------
   function Get_Line_Info (UI : in UIComponent'Class) return String is
   begin
      if UI.Tag /= null then
         return UI.Tag.Get_Line_Info;
      else
         return UI.Tag.Get_Line_Info;
      end if;
   end Get_Line_Info;

end ASF.Components.Utils;

Implement the Get_Line_Info function

Implement the Get_Line_Info function


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                          A 4 G . C O N T T . T T                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or  FITNESS FOR A  PARTICULAR PURPOSE.  See the GNU General --
-- Public License for more details.  You should have received a copy of the --
-- GNU  General  Public  License  distributed with  ASIS-for-GNAT; see file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences.  ASIS-for-GNAT is now maintained by  AdaCore                   --
-- (http://www.adacore.com).                                                --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines Tree Table, which contains the information
--  about the tree output files needed for swapping the ASTs accessed
--  by ASIS. This information includes such things as Asis Compilation
--  Units, and their top nodes in the tree.

with Asis;            use Asis;
with Asis.Compilation_Units;
with Asis.Errors;     use Asis.Errors;

with Asis.Set_Get;    use Asis.Set_Get;

with A4G.A_Debug;     use A4G.A_Debug;
with A4G.A_Output;    use A4G.A_Output;
with A4G.Asis_Tables; use A4G.Asis_Tables;
with A4G.Contt.UT;    use A4G.Contt.UT;
with A4G.Get_Unit;    use A4G.Get_Unit;
with A4G.Vcheck;      use A4G.Vcheck;

with Atree;           use Atree;
with Lib;             use Lib;
with Namet;           use Namet;
with Nlists;          use Nlists;
with Output;          use Output;
with Sinfo;           use Sinfo;
with Sinput;          use Sinput;
with Tree_In;

package body A4G.Contt.TT is

   procedure Set_Nil_Tree_Names (T : Tree_Id);
   --  Sets all the fields related to Source File Name Table as indicating
   --  empty  strings

   procedure Set_Nil_Tree_Attributes (T : Tree_Id);
   --  Sets all the attributes of T as if T is an ASIS Nil_Tree

   function Find_Enclosed_Decl
     (Scope : Node_Id;
      J         : Int)
      return Node_Id;
   --  Starting from Scope, looks for the nested scope which is stored
   --  in Node_Trace table as Node_Trase.Table (J). Node, that expanded
   --  generic specs are considered as ordinary scopes.

   -------------------------
   -- Allocate_Tree_Entry --
   -------------------------

   function Allocate_Tree_Entry return Tree_Id is
      New_Last : Tree_Id;
      --  the Id of the new entry being allocated in the Unit Table
   begin

      Tree_Table.Increment_Last;
      New_Last := Tree_Table.Last;

      Set_Nil_Tree_Names      (New_Last);
      Set_Nil_Tree_Attributes (New_Last);

      Tree_Table.Table (New_Last).Tree_Name_Chars_Index := A_Name_Chars.Last;

      Tree_Table.Table (New_Last).Tree_Name_Len := Short (A_Name_Len);

      --  Set corresponding string entry in the Name_Chars table

      for I in 1 .. A_Name_Len loop
         A_Name_Chars.Increment_Last;

         A_Name_Chars.Table (A_Name_Chars.Last) := A_Name_Buffer (I);
      end loop;

      A_Name_Chars.Increment_Last;
      A_Name_Chars.Table (A_Name_Chars.Last) := ASCII.NUL;
      return New_Last;

   end Allocate_Tree_Entry;

   ------------------------------------------
   -- Current_Tree_Consistent_With_Sources --
   ------------------------------------------

   function Current_Tree_Consistent_With_Sources return Boolean is
      Result       : Boolean := True;
      Source_Stamp : Time_Stamp_Type;
      Tree_Stamp   : Time_Stamp_Type;
      Source       : File_Name_Type;
   begin

      for J in 2 .. Last_Source_File loop
         --  We start from 2, because the entry 1 in the Source File Table
         --  is always for system.ads (see Sinput, spec).
         Tree_Stamp := Time_Stamp (J);

         Source := Full_File_Name (J);

         Get_Name_String (Source);
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := ASCII.NUL;

         if not Is_Regular_File (Name_Buffer) then
            --  The source file was (re)moved
            Result := False;
            exit;

         else
            Source_Stamp := TS_From_OS_Time (File_Time_Stamp (Name_Buffer));

            if Source_Stamp /= Tree_Stamp then
               --  The source file has been changed
               Result := False;
               exit;
            end if;

         end if;

      end loop;

      return Result;

   end Current_Tree_Consistent_With_Sources;

   ------------------------
   -- Find_Enclosed_Decl --
   ------------------------

   function Find_Enclosed_Decl
     (Scope : Node_Id;
      J     : Int)
      return Node_Id
   is
      Result : Node_Id := Empty;

      List_To_Search : List_Id;
      Kind_To_Search : constant Node_Kind := Node_Trace.Table (J).Kind;

      Line_To_Search : constant Physical_Line_Number :=
        Node_Trace.Table (J).Node_Line;

      Col_To_Search  : constant Column_Number :=
        Node_Trace.Table (J).Node_Col;

      function Check_Node (N : Node_Id) return Traverse_Result;
      --  Check if N is the needed node. If it is, Sets Result equial to N and
      --  returns Abandon. Othervise returns OK.

      function Find_In_List (L : List_Id) return Node_Id;
      --  Looks for the needed scope in a node list

      procedure Traverse_Scope is new
        Atree.Traverse_Proc (Process => Check_Node);

      function Check_Node (N : Node_Id) return Traverse_Result is
         N_Sloc       : Source_Ptr;
         Traverse_Res : Traverse_Result := OK;
      begin

         if Nkind (N) = Kind_To_Search then
            N_Sloc := Sloc (N);

            if Get_Physical_Line_Number (N_Sloc) = Line_To_Search
              and then
               Get_Column_Number (N_Sloc)        = Col_To_Search
            then
               Result       := N;
               Traverse_Res := Abandon;
            end if;

         end if;

         return Traverse_Res;
      end Check_Node;

      function Find_In_List (L : List_Id) return Node_Id is
         Res       : Node_Id := Empty;
         Next_Node : Node_Id;
         Next_Sloc : Source_Ptr;
      begin
         Next_Node := First_Non_Pragma (L);

         while Present (Next_Node) loop

            if Nkind (Next_Node) = Kind_To_Search then
               Next_Sloc := Sloc (Next_Node);

               if Get_Physical_Line_Number (Next_Sloc) = Line_To_Search
                 and then
                  Get_Column_Number (Next_Sloc)        = Col_To_Search
               then
                  Res := Next_Node;
                  exit;
               end if;

            end if;

            Next_Node := Next_Non_Pragma (Next_Node);

         end loop;

         return Res;
      end Find_In_List;

   begin

      if Nkind (Scope) = N_Package_Instantiation then
         Result := Scope;

         while Nkind (Result) /= N_Package_Declaration loop
            Result := Prev_Non_Pragma (Result);
         end loop;

         return Result;

      end if;

      if Nkind (Scope) = N_Package_Body
        or else
         Nkind (Scope) = N_Subprogram_Body
        or else
         Nkind (Scope) = N_Block_Statement
      then
         List_To_Search := Sinfo.Declarations (Scope);
      else
         List_To_Search := Visible_Declarations (Scope);
      end if;

      Result := Find_In_List (List_To_Search);

      if No (Result) then

         if Nkind (Scope) = N_Package_Specification then
            List_To_Search := Private_Declarations (Scope);
            Result         := Find_In_List (List_To_Search);

            if No (Result)
              and then
               Nkind (Parent (Scope)) = N_Generic_Package_Declaration
            then
               List_To_Search := Generic_Formal_Declarations (Parent (Scope));
               Result         := Find_In_List (List_To_Search);
            end if;

         elsif Nkind (Scope) = N_Block_Statement
            or else
               Nkind (Scope) = N_Subprogram_Body
         then
            --  We can have an instantiation nested in some block statement in
            --  tne library subprogram body. This should not happen too often,
            --  so we can use this performance-expensive approach here.
            Traverse_Scope (Scope);
         end if;

      end if;

      pragma Assert (Present (Result));

      return Result;

   end Find_Enclosed_Decl;

   -------------------
   -- Get_Tree_Name --
   -------------------

   function Get_Tree_Name (C : Context_Id; Id : Tree_Id) return String is
   begin
      Get_Name_String (C, Id);
      return A_Name_Buffer (1 ..  A_Name_Len);
   end Get_Tree_Name;

   -----------------------------
   -- Restore_Node_From_Trace --
   -----------------------------

   function Restore_Node_From_Trace
     (In_Body : Boolean               := False;
      CU      : Asis.Compilation_Unit := Asis.Nil_Compilation_Unit)
      return    Node_Id
   is
      Start_Node : Node_Id;
      Result     : Node_Id := Empty;
   begin

      if Asis.Compilation_Units.Is_Nil (CU) then
         Start_Node := Unit (Cunit (Main_Unit));

         if Nkind (Start_Node) = N_Package_Body and then
            not In_Body
         then
            Start_Node := Corresponding_Spec (Start_Node);

            while not (Nkind (Start_Node) = N_Package_Declaration
                     or else
                        Nkind (Start_Node) = N_Generic_Package_Declaration)
            loop
               Start_Node := Parent (Start_Node);
            end loop;

         end if;
      else
         Start_Node := Unit (Top (CU));
      end if;

      if Node_Trace.First = Node_Trace.Last then
         --  One-element trace means, that we have a library-level package
         --  instantiation
         Result := Start_Node;
      else

         if Nkind (Start_Node) = N_Package_Declaration
           or else
             Nkind (Start_Node) = N_Generic_Package_Declaration
         then
            Start_Node := Specification (Start_Node);
         end if;

         for J in reverse Node_Trace.First + 1 .. Node_Trace.Last - 1 loop
            Start_Node := Find_Enclosed_Decl (Start_Node, J);

            if Nkind (Start_Node) = N_Package_Declaration
              or else
               Nkind (Start_Node) = N_Generic_Package_Declaration
            then
               Start_Node := Specification (Start_Node);
            end if;

         end loop;

         Result := Find_Enclosed_Decl (Start_Node, Node_Trace.First);

      end if;

      pragma Assert (Present (Result));

      return Result;

   end Restore_Node_From_Trace;

   ---------------------
   -- Get_Name_String --
   ---------------------

   procedure Get_Name_String (C : Context_Id; Id : Tree_Id) is
      S : Int;
      L : Short;

   begin

      Reset_Context (C); --  ???

      S := Tree_Table.Table (Id).Tree_Name_Chars_Index;
      L := Tree_Table.Table (Id).Tree_Name_Len;

      A_Name_Len := Natural (L);

      for I in 1 .. A_Name_Len loop
         A_Name_Buffer (I) := A_Name_Chars.Table (S + Int (I));
      end loop;
   end Get_Name_String;

   -----------------
   -- Print_Trees --
   -----------------
   procedure Print_Trees (C : Context_Id) is
   begin
      Write_Str ("Tree Table for Context number: ");
      Write_Int (Int (C));
      Write_Eol;

      if C = Non_Associated then
         Write_Str ("   Nil Context, it can never be associated ");
         Write_Str ("with any tree");
         Write_Eol;
         return;
      end if;

      if Is_Opened (C) then
         for Tr in First_Tree_Id .. Last_Tree (C) loop
            Output_Tree (C, Tr);
         end loop;
         Write_Eol;
      else
         Write_Str ("This Context is closed");
         Write_Eol;
      end if;
   end Print_Trees;

   -----------------------------
   -- Set_Nil_Tree_Attributes --
   -----------------------------

   procedure Set_Nil_Tree_Attributes (T : Tree_Id) is
   begin
      Set_Main_Unit_Id (T, Nil_Unit);
      Set_Main_Top (T, Empty);
      Tree_Table.Table (T).Units := No_Elist;
   end Set_Nil_Tree_Attributes;

   ------------------------
   -- Set_Nil_Tree_Names --
   ------------------------

   procedure Set_Nil_Tree_Names (T : Tree_Id) is
      Tr : constant Tree_Id := T;
   begin
      Tree_Table.Table (Tr).Tree_Name_Chars_Index := 0;
      Tree_Table.Table (Tr).Tree_Name_Len         := 0;
   end Set_Nil_Tree_Names;

   ---------------------------------------------------------------
   --  Internal Tree Unit Attributes Access and Update Routines --
   ---------------------------------------------------------------

   function Main_Unit_Id (T : Tree_Id) return Unit_Id is
   begin
      return Tree_Table.Table (T).Main_Unit;
   end Main_Unit_Id;

   function Main_Unit_Id return Unit_Id is
   begin
      return Tree_Table.Table (Current_Tree).Main_Unit;
   end Main_Unit_Id;

   procedure Set_Main_Unit_Id (T : Tree_Id; U : Unit_Id) is
   begin
      Tree_Table.Table (T).Main_Unit := U;
   end Set_Main_Unit_Id;

   procedure Set_Main_Top  (T : Tree_Id; N : Node_Id) is
   begin
      Tree_Table.Table (T).Main_Top := N;
   end Set_Main_Top;

   procedure Set_Main_Unit_Id (U : Unit_Id) is
   begin
      Tree_Table.Table (Current_Tree).Main_Unit := U;
   end Set_Main_Unit_Id;

   procedure Set_Main_Top  (N : Node_Id) is
   begin
      Tree_Table.Table (Current_Tree).Main_Top := N;
   end Set_Main_Top;

   -----------------------------------
   -- Subprograms for Tree Swapping --
   -----------------------------------

   -----------------------------------
   -- Append_Full_View_Tree_To_Unit --
   -----------------------------------

   procedure Append_Full_View_Tree_To_Unit (C : Context_Id; U : Unit_Id) is
   begin
      Reset_Context (C);
      Add_To_Elmt_List (Unit_Id (Current_Tree),
                        Unit_Table.Table (U).Full_View_Trees);
   end Append_Full_View_Tree_To_Unit;

   --------------------------------------
   -- Append_Limited_View_Tree_To_Unit --
   --------------------------------------

   procedure Append_Limited_View_Tree_To_Unit (C : Context_Id; U : Unit_Id) is
   begin
      Reset_Context (C);
      Add_To_Elmt_List (Unit_Id (Current_Tree),
                        Unit_Table.Table (U).Limited_View_Trees);
   end Append_Limited_View_Tree_To_Unit;

   -------------------
   -- Reorder_Trees --
   -------------------

   procedure Reorder_Trees (C : Context_Id) is
      Main_Unit : Unit_Id;
      --  The unit which main tree should be moved to the first position in
      --  the list of trees for the unit being processed in a loop

      First_Tree : Tree_Id;
      Success    : Boolean;
      C_Mode     : constant Context_Mode := Context_Processing_Mode (C);
   begin

      for U in First_Unit_Id + 1 .. Last_Unit loop
         --  First_Unit_Id corresponds to Standard

         Success   := True;
         Main_Unit := Nil_Unit;

         case Kind (C, U) is
            when A_Subunit =>
               --  (1)
               Main_Unit := Get_Subunit_Parent_Body (C, U);

               while Kind (C, Main_Unit) in A_Subunit loop
                  Main_Unit := Get_Subunit_Parent_Body (C, Main_Unit);
               end loop;

               if No (Main_Tree (C, Main_Unit)) then

                  if C_Mode in Partition .. All_Trees then
                     Get_Name_String (U, Ada_Name);

                     ASIS_Warning
                        (Message =>
                           "Asis.Ada_Environments.Open: " &
                           "ancestor body is not compiled for subunit " &
                            A_Name_Buffer (1 .. A_Name_Len),
                         Error   => Data_Error);
                  end if;

                  Success := False;
               end if;

            when A_Package           |
                 A_Generic_Package   |
                 A_Procedure         |
                 A_Function          |
                 A_Generic_Procedure |
                 A_Generic_Function  =>

               --  (2), (3) and (5)

               if Is_Body_Required (C, U)           or else
                  Kind (C, U) = A_Procedure         or else
                  Kind (C, U) = A_Function          or else
                  Kind (C, U) = A_Generic_Procedure or else
                  Kind (C, U) = A_Generic_Function
               then
                  --  (2) and (5)
                  Main_Unit := Get_Body (C, U);

                  if No (Main_Unit) or else
                     No (Main_Tree (C, Main_Unit))
                  then
                     --  The second condition corresponds to the situation when
                     --  the tree is created for library-level generic spec
                     --  which requires the body

                     if C_Mode in Partition .. All_Trees and then
                        Origin (C, U) = An_Application_Unit
                     then
                        Get_Name_String (U, Ada_Name);

                        ASIS_Warning
                           (Message =>
                                "Asis.Ada_Environments.Open: "
                              & "body is not compiled for "
                              &  A_Name_Buffer (1 .. A_Name_Len),
                            Error   => Data_Error);
                     end if;

                     Success := False;
                  end if;

               else
                  --  (3)
                  Main_Unit := U;

                  if No (Main_Tree (C, Main_Unit)) then
                     --  We do not generate any warning in this case, because
                     --  we do not know whether or not this package
                     --  declaration has to be compiled on its own. So we only
                     --  set Success OFF to prevent any change in the tree
                     --  list
                     Success := False;
                  end if;

               end if;

            when A_Generic_Unit_Instance =>
               --  (4)
               Main_Unit := U;

               if No (Main_Tree (C, Main_Unit)) then

                  if C_Mode in Partition .. All_Trees and then
                     Origin (C, U) = An_Application_Unit
                  then
                     Get_Name_String (U, Ada_Name);

                     ASIS_Warning
                        (Message =>
                            "Asis.Ada_Environments.Open: "
                          & "library-level instance "
                          &  A_Name_Buffer (1 .. A_Name_Len)
                          & " is not compiled",
                         Error   => Data_Error);
                  end if;

                  Success := False;
               end if;

            when A_Library_Unit_Body =>
               --  There are some situations when the body is compiled because
               --  the corresponding spec is a supporter of the main unit of
               --  the compilation. See Lib (spec), (h)
               Main_Unit := U;

               if No (Main_Tree (C, Main_Unit)) then
                  --  We do notr generate a warning here - if needed, the
                  --  warning is generated for the corresponding spec
                  Success := False;
               end if;

            when others =>
               null;
         end case;

         if Success and then Present (Main_Unit) then
            --  Here we have to reorder the trees for U. Currently the
            --  simplest solution is used - we just prepend the right tree
            --  to the tree list, if it is not already the first tree in
            --  the list. So this tree may be duplicated in the list.
            First_Tree := Main_Tree (C, Main_Unit);

            if First_Tree /=
              Tree_Id
                (Unit (First_Elmt (Unit_Table.Table (U).Full_View_Trees)))
            then
               Prepend_Elmt
                 (Unit_Id (First_Tree), Unit_Table.Table (U).Full_View_Trees);
            end if;

         end if;

      end loop;

   end Reorder_Trees;

   ----------------
   -- Reset_Tree --
   ----------------

   procedure Reset_Tree (Context : Context_Id; Tree : Tree_Id) is
      Tree_File_FD : File_Descriptor;
      File_Closed  : Boolean := False;
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (Current_Context) = GNSA then
         --  This is no more than a workaround for -GNSA C1 Context when we
         --  have exactly one tree (and exactly one (GNSA) Context!
         return;
      end if;

      if Context = Current_Context and then
         Tree    = Current_Tree
      then
         return;
      end if;

      if Debug_Flag_T then
         Write_Str ("In Context ");
         Write_Int (Int (Context));
         Write_Str (" resetting the tree ");
         Write_Int (Int (Tree));
         Write_Eol;
      end if;

      --  the following call to Reset_Context is redundant, because the next
      --  call to Get_Name_String also resets Context, but this is the right
      --  place for Reset_Context
      Reset_Context (Context);

      Get_Name_String (Context, Tree);
      --  should be always successful, because Tree may correspond only to
      --  some tree file, which has been investigated by ASIS

      A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL;

      if Debug_Flag_T then
         Write_Str (" (");
         Write_Str (A_Name_Buffer (1 .. A_Name_Len));
         Write_Str (")");
         Write_Eol;

      end if;

      Tree_File_FD := Open_Read (A_Name_Buffer'Address, Binary);

      if Tree_File_FD = Invalid_FD then
         Raise_ASIS_Failed
           (Diagnosis => "A4G.Contt.TT.Reset_Tree: "      &
                         "Cannot open tree file: "        &
                          A_Name_Buffer (1 .. A_Name_Len) &
                          ASIS_Line_Terminator            &
                          "ASIS external environment may have been changed",
            Stat      => Data_Error);
      end if;

      begin
         Tree_In (Tree_File_FD);
      exception
         when others =>
            Close (Tree_File_FD, File_Closed);

            --  We did not chech File_Closed here, because the problem in
            --  Tree_In seems to be more important for ASIS

            Raise_ASIS_Failed
              (Diagnosis => "A4G.Contt.TT.Reset_Tree: "      &
                            "Can not read tree file: "       &
                             A_Name_Buffer (1 .. A_Name_Len) &
                             ASIS_Line_Terminator            &
                             "ASIS external environment may have been changed",
               Stat      => Data_Error);
      end;

      Close (Tree_File_FD, File_Closed);

      if not File_Closed then
         Raise_ASIS_Failed
           (Diagnosis => "A4G.Contt.TT.Reset_Tree: "      &
                         "Can not close tree file: "      &
                          A_Name_Buffer (1 .. A_Name_Len) &
                          ASIS_Line_Terminator            &
                          "disk is full or file may be used by other program",
            Stat      => Data_Error);
      end if;

      --  if we are here, then the required tree has been successfully
      --  re-retrieved. So:

      Current_Context := Context;
      Current_Tree    := Tree;

      if Debug_Flag_T then
         Write_Str ("In Context ");
         Write_Int (Int (Context));
         Write_Str (" the tree ");
         Write_Int (Int (Tree));
         Write_Str (" has been reset");
         Write_Eol;
      end if;

   end Reset_Tree;

   -----------------------------
   --  Reset_Tree_For_Element --
   -----------------------------

   procedure Reset_Tree_For_Element (E : Asis.Element) is
   begin
      Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E));
   end Reset_Tree_For_Element;

   -------------------------
   -- Reset_Tree_For_Unit --
   -------------------------

   procedure Reset_Tree_For_Unit (C : Context_Id; U : Unit_Id) is
      Tree_List   : Elist_Id;
      Tree_To_Set : Tree_Id;
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (Get_Current_Cont) = GNSA then
         --  This is no more than a workaround for -GNSA C1 Context when we
         --  have exactly one tree (and exactly one (GNSA) Context!
         return;
      end if;

      Tree_List  := Unit_Table.Table (U).Full_View_Trees;

      if No (Tree_List) or else No (First_Elmt (Tree_List)) then
         Tree_List  := Unit_Table.Table (U).Limited_View_Trees;
      end if;
      --  it cannot be No_List or Empty_List!

      Tree_To_Set := Tree_Id (Unit (First_Elmt (Tree_List)));

      if Debug_Flag_T then
         Write_Str ("For unit ");
         Write_Int (Int (U));
         Write_Str (" ");
      end if;

      Reset_Tree (Context => C,
                  Tree    => Tree_To_Set);
   end Reset_Tree_For_Unit;

   procedure Reset_Tree_For_Unit (Unit : Asis.Compilation_Unit) is
   begin
      Reset_Tree_For_Unit (Encl_Cont_Id (Unit), Get_Unit_Id (Unit));
   end Reset_Tree_For_Unit;

   -------------------------
   -- Reset_Instance_Tree --
   -------------------------

   procedure Reset_Instance_Tree
     (Lib_Level_Instance : Asis.Compilation_Unit;
      Decl_Node          : in out Node_Id)
   is
      U            : Unit_Id := Get_Unit_Id (Lib_Level_Instance);
      Tree_To_Set  : Tree_Id;
      Curr_Context : constant Context_Id := Get_Current_Cont;
      Curr_Tree    : constant Tree_Id    := Get_Current_Tree;
      In_Body      : Boolean := False;
   begin
      --  Special processing for GNSA mode:

      if Tree_Processing_Mode (Curr_Context) = GNSA then
         --  This is no more than a workaround for -GNSA C1 Context when we
         --  have exactly one tree (and exactly one (GNSA) Context!
         return;
      end if;

      Tree_To_Set :=
         Unit_Table.Table (U).Main_Tree;

      if No (Tree_To_Set) then

         if Kind (Lib_Level_Instance) in A_Package .. A_Generic_Package or else
            Kind (Lib_Level_Instance) in A_Library_Unit_Body
         then
            U := Get_Body (Current_Context, U);

            if Tree_Processing_Mode (Curr_Context) = Incremental and then
               (No (U) or else
                No (Unit_Table.Table (U).Main_Tree))
            then
               --  In this situation we try to compile the needed body on the
               --  fly
               if Is_Body_Required (Lib_Level_Instance) or else
                  Kind (Lib_Level_Instance) in A_Library_Unit_Body
               then

                  U := Get_Main_Unit_Tree_On_The_Fly
                        (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                        Cont       => Curr_Context,
                        Spec       => False);
               else
                  U := Get_Main_Unit_Tree_On_The_Fly
                        (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                        Cont       => Curr_Context,
                        Spec       => True);
               end if;

            end if;

         elsif Kind (Lib_Level_Instance) in A_Generic_Unit_Instance and then
               Tree_Processing_Mode (Encl_Cont_Id (Lib_Level_Instance)) =
               Incremental
         then
               U := Get_Main_Unit_Tree_On_The_Fly
                      (Start_Unit => Get_Unit_Id (Lib_Level_Instance),
                       Cont       => Curr_Context,
                       Spec       => True);
         end if;

         if Present (U) then

            Tree_To_Set := Unit_Table.Table (U).Main_Tree;

            Reset_Tree (Context => Get_Current_Cont,
                        Tree    => Curr_Tree);
         end if;

      end if;

      if No (Tree_To_Set) or else Tree_To_Set = Current_Tree then
         return;
      end if;

      Create_Node_Trace (Decl_Node);

      Reset_Tree (Context => Get_Current_Cont,
                  Tree    => Tree_To_Set);

      if Kind (Lib_Level_Instance) in A_Library_Unit_Body then
         In_Body := True;
      end if;

      Decl_Node := Restore_Node_From_Trace (In_Body);

   end Reset_Instance_Tree;

   ----------------------------------
   -- Tree_Consistent_With_Sources --
   ----------------------------------

   function Tree_Consistent_With_Sources
     (E :    Asis.Element)
      return Boolean
   is
   begin

      Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E));

      return Current_Tree_Consistent_With_Sources;

   end Tree_Consistent_With_Sources;

   function Tree_Consistent_With_Sources
     (CU :   Asis.Compilation_Unit)
      return Boolean
   is
   begin
      Reset_Tree_For_Unit (CU);
      return Current_Tree_Consistent_With_Sources;
   end Tree_Consistent_With_Sources;

   --------------------------
   -- Unit_In_Current_Tree --
   --------------------------

   function Unit_In_Current_Tree (C : Context_Id; U : Unit_Id) return Boolean
   is
   begin
      if U = Standard_Id then
         return True;
      end if;

      if Current_Context /= C then
         return False;
      end if;

      return
        In_Elmt_List
          (Unit_Id (Current_Tree), Unit_Table.Table (U).Full_View_Trees)
       or else
          (No (Unit_Table.Table (U).Full_View_Trees)
           and then
           In_Elmt_List
            (Unit_Id (Current_Tree), Unit_Table.Table (U).Limited_View_Trees));

   end Unit_In_Current_Tree;

--------------------------------------------------
--    General-Purpose Tree Table Subprograms    --
--------------------------------------------------

   ---------------
   -- Last_Tree --
   ---------------

   function Last_Tree (C : Context_Id) return Tree_Id is
   begin
      Reset_Context (C);
      return Tree_Table.Last;
   end Last_Tree;

   --------
   -- No --
   --------

   function No (Tree : Tree_Id) return Boolean is
   begin
      return Tree = Nil_Tree;
   end No;

   -----------------
   -- Output_Tree --
   -----------------

   procedure Output_Tree (C : Context_Id; Tree : Tree_Id) is
   begin

      --  ???  Check for Debug_Mode should be moved into the context(s) where
      --  ???  Output_Tree is called

      if Debug_Mode   or else
         Debug_Flag_C or else
         Debug_Lib_Model
      then
         Write_Str ("Debug output for Tree Id " & Tree_Id'Image (Tree));
         Write_Eol;

         if Tree = Nil_Tree then
            Write_Str ("This is a Nil Tree");
            Write_Eol;
            return;
         end if;

         Get_Name_String (C, Tree);

         Write_Str ("Tree File Name is: " & A_Name_Buffer (1 ..  A_Name_Len));
         Write_Eol;

         Write_Str ("Main Unit Id : ");
         Write_Str (Main_Unit_Id (Tree)'Img);
         Write_Eol;

         Write_Str ("The list of the Units contained in the tree:");
         Write_Eol;

         Print_List (Tree_Table.Table (Tree).Units);

         Write_Eol;
      end if;

   end Output_Tree;

   -------------
   -- Present --
   -------------

   function Present (Tree : Tree_Id) return Boolean is
   begin
      return Tree /= No_Tree_Name;
   end Present;

end A4G.Contt.TT;

Add the ASIS file $i

Add the ASIS file $i