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

with Util.Beans;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;

--  This sample reads an UML 1.4 model saved in XMI 1.2 format.  It uses the serialization
--  framework to indicate what XML nodes and attributes must be reported.
procedure XMI is

   use type Ada.Text_IO.Count;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type XMI_Fields is (FIELD_CLASS_NAME, FIELD_CLASS_ID, FIELD_STEREOTYPE,
                       FIELD_ATTRIBUTE_NAME,
                       FIELD_PACKAGE_NAME,
                       FIELD_PACKAGE_END,
                       FIELD_CLASS_VISIBILITY,
                       FIELD_DATA_TYPE,
                       FIELD_ENUM_DATA_TYPE,
                       FIELD_CLASS_END,
                       FIELD_MULTIPLICITY_LOWER,
                       FIELD_MULTIPLICITY_UPPER,
                       FIELD_ASSOCIATION_AGGREGATION,
                       FIELD_ASSOCIATION_NAME,
                       FIELD_ASSOCIATION_VISIBILITY,
                       FIELD_ASSOCIATION_END_ID,
                       FIELD_TAG_DEFINITION_ID,
                       FIELD_TAG_DEFINITION_NAME,
                       FIELD_OPERATION_NAME,
                       FIELD_COMMENT_NAME,
                       FIELD_COMMENT_BODY,
                       FIELD_COMMENT_CLASS_ID,
                       FIELD_TAGGED_VALUE_TYPE,
                       FIELD_TAGGED_VALUE_VALUE);

   type XMI_Info is record
      Indent : Ada.Text_IO.Count := 1;
   end record;
   type XMI_Access is access all XMI_Info;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Print (Col  : in Ada.Text_IO.Count;
                    Line : in String) is
   begin
      Ada.Text_IO.Set_Col (Col);
      Ada.Text_IO.Put_Line (Line);
   end Print;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
      when FIELD_CLASS_NAME =>
         Print (P.Indent, "Class " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_CLASS_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_CLASS_ID =>
         Print (P.Indent, "id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ATTRIBUTE_NAME =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("attr: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_LOWER =>
         Ada.Text_IO.Put (" " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_UPPER =>
         Ada.Text_IO.Put_Line (".." & Util.Beans.Objects.To_String (Value));

      when FIELD_STEREOTYPE =>
         Print (P.Indent, "<<" & Util.Beans.Objects.To_String (Value) & ">>");

      when FIELD_DATA_TYPE =>
         Print (P.Indent, "  data-type:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ENUM_DATA_TYPE =>
         Print (P.Indent, "  enum-type:" & Util.Beans.Objects.To_String (Value));

      when FIELD_CLASS_END =>
         P.Indent := P.Indent - 2;

      when FIELD_OPERATION_NAME =>
         Print (P.Indent, "operation:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_NAME =>
         Print (P.Indent, "association " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_AGGREGATION =>
         Print (P.Indent, "   aggregate: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_END_ID =>
         Print (P.Indent, "   end-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_NAME =>
         Print (P.Indent, "package " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_PACKAGE_END =>
         P.Indent := P.Indent - 2;

      when FIELD_TAGGED_VALUE_VALUE =>
         Print (P.Indent, "tag-value: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAGGED_VALUE_TYPE =>
         Print (P.Indent, "tag-type: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_NAME =>
         Print (P.Indent, "Tag: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_ID =>
         Print (P.Indent, "  tag-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_NAME =>
         Print (P.Indent, "Comment: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_BODY =>
         Print (P.Indent, "   text: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_CLASS_ID =>
         Print (P.Indent, "   for-id: " & Util.Beans.Objects.To_String (Value));
         --
         --        when others =>
         --           Ada.Text_IO.Put_Line ("  member " & XMI_Fields'Image (Field)
         --                                 & " to " & Util.Beans.Objects.To_String (Value));
      end case;
   end Set_Member;

   package XMI_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => XMI_Info,
                                               Element_Type_Access => XMI_Access,
                                               Fields              => XMI_Fields,
                                               Set_Member          => Set_Member);

   XMI_Mapping        : aliased XMI_Mapper.Mapper;

begin
   --     Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmi file...");
      Ada.Text_IO.Put_Line ("Example xmi samples/demo-atlas.xmi");
      return;
   end if;

   --  Define the XMI mapping.
   XMI_Mapping.Add_Mapping ("Package/*/@name",
                            FIELD_PACKAGE_NAME);
   XMI_Mapping.Add_Mapping ("Package",
                            FIELD_PACKAGE_END);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/@name",
                            FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/@xmi.id",
                            FIELD_CLASS_ID);
   XMI_Mapping.Add_Mapping ("Package/*/Class",
                            FIELD_CLASS_END);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/@visibility",
                            FIELD_CLASS_VISIBILITY);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Stereotype/@href",
                            FIELD_STEREOTYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/@name",
                            FIELD_ATTRIBUTE_NAME);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/Stereotype/@href",
                            FIELD_STEREOTYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/TaggedValue.dataValue",
                            FIELD_TAGGED_VALUE_VALUE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/TaggedValue.dataValue/*/TagDefinition/@href",
                            FIELD_TAGGED_VALUE_TYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/DataType/@href",
                            FIELD_DATA_TYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/Enumeration/@href",
                            FIELD_ENUM_DATA_TYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/TaggedValue.dataValue",
                            FIELD_TAGGED_VALUE_VALUE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/TaggedValue.type/*/TagDefinition/@href",
                            FIELD_TAGGED_VALUE_TYPE);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/MultiplicityRange/@lower",
                            FIELD_MULTIPLICITY_LOWER);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Attribute/*/MultiplicityRange/@upper",
                            FIELD_MULTIPLICITY_UPPER);
   XMI_Mapping.Add_Mapping ("Package/*/Class/*/Operation/@name",
                            FIELD_OPERATION_NAME);
   XMI_Mapping.Add_Mapping ("Package/*/Association/*/@name",
                            FIELD_ASSOCIATION_NAME);
   XMI_Mapping.Add_Mapping ("Package/*/Association/*/@visibility",
                            FIELD_ASSOCIATION_VISIBILITY);
   XMI_Mapping.Add_Mapping ("Package/*/Association/*/@aggregation",
                            FIELD_ASSOCIATION_AGGREGATION);
   XMI_Mapping.Add_Mapping ("Package/*/Association/*/AssociationEnd.participant/Class/@xmi.idref",
                            FIELD_ASSOCIATION_END_ID);
   XMI_Mapping.Add_Mapping ("TagDefinition/@name",
                            FIELD_TAG_DEFINITION_NAME);
   XMI_Mapping.Add_Mapping ("TagDefinition/@xm.id",
                            FIELD_TAG_DEFINITION_ID);
   XMI_Mapping.Add_Mapping ("Package/*/Comment/@name",
                            FIELD_COMMENT_NAME);
   XMI_Mapping.Add_Mapping ("Package/*/Comment/@body",
                            FIELD_COMMENT_BODY);
   XMI_Mapping.Add_Mapping ("Package/*/Comment/Comment.annotatedElement/*/@xmi.idref",
                            FIELD_COMMENT_CLASS_ID);

   Reader.Add_Mapping ("XMI/*/Model/*", XMI_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);
         Data : aliased XMI_Info;
      begin
         XMI_Mapper.Set_Context (Reader, Data'Unchecked_Access);
         Reader.Parse (S);
      end;
   end loop;
end XMI;

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

with Util.Log.Loggers;
with Util.Beans;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;

--  This sample reads an UML 1.4 model saved in XMI 1.2 format.  It uses the serialization
--  framework to indicate what XML nodes and attributes must be reported.
procedure XMI is

   use type Ada.Text_IO.Count;

   Reader : Util.Serialize.IO.XML.Parser;

   Count  : constant Natural := Ada.Command_Line.Argument_Count;

   type XMI_Fields is (FIELD_CLASS_NAME, FIELD_CLASS_ID, FIELD_STEREOTYPE,
                       FIELD_ATTRIBUTE_NAME,
                       FIELD_PACKAGE_NAME,
                       FIELD_PACKAGE_END,
                       FIELD_VISIBILITY,
                       FIELD_DATA_TYPE,
                       FIELD_ENUM_DATA_TYPE,
                       FIELD_ENUM_NAME,
                       FIELD_ENUM_END,
                       FIELD_ENUM_LITERAL,
                       FIELD_ENUM_LITERAL_END,
                       FIELD_CLASS_END,
                       FIELD_MULTIPLICITY_LOWER,
                       FIELD_MULTIPLICITY_UPPER,
                       FIELD_ASSOCIATION_AGGREGATION,
                       FIELD_ASSOCIATION_NAME,
                       FIELD_ASSOCIATION_VISIBILITY,
                       FIELD_ASSOCIATION_END_ID,
                       FIELD_ASSOCIATION_END,
                       FIELD_TAG_DEFINITION_ID,
                       FIELD_TAG_DEFINITION_NAME,
                       FIELD_OPERATION_NAME,
                       FIELD_COMMENT_NAME,
                       FIELD_COMMENT_BODY,
                       FIELD_COMMENT_CLASS_ID,
                       FIELD_TAGGED_VALUE_TYPE,
                       FIELD_TAGGED_VALUE_VALUE);

   type XMI_Info is record
      Indent : Ada.Text_IO.Count := 1;
   end record;
   type XMI_Access is access all XMI_Info;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Print (Col  : in Ada.Text_IO.Count;
                    Line : in String) is
   begin
      Ada.Text_IO.Set_Col (Col);
      Ada.Text_IO.Put_Line (Line);
   end Print;

   procedure Set_Member (P     : in out XMI_Info;
                         Field : in XMI_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
      when FIELD_CLASS_NAME =>
         Print (P.Indent, "Class " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_CLASS_ID =>
         Print (P.Indent, "id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ATTRIBUTE_NAME =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("attr: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_LOWER =>
         Ada.Text_IO.Set_Col (P.Indent);
         Ada.Text_IO.Put ("  multiplicity: " & Util.Beans.Objects.To_String (Value));

      when FIELD_MULTIPLICITY_UPPER =>
         Ada.Text_IO.Put_Line (".." & Util.Beans.Objects.To_String (Value));

      when FIELD_STEREOTYPE =>
         Print (P.Indent, "<<" & Util.Beans.Objects.To_String (Value) & ">>");

      when FIELD_DATA_TYPE =>
         Print (P.Indent, "  data-type:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ENUM_DATA_TYPE =>
         Print (P.Indent, "  enum-type:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_NAME =>
         Print (P.Indent, "  enum " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ENUM_LITERAL =>
         Print (P.Indent, "  enum:" & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_OPERATION_NAME =>
         Print (P.Indent, "operation:" & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_NAME =>
         Print (P.Indent, "association " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_ASSOCIATION_VISIBILITY =>
         Print (P.Indent, "visibility: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_AGGREGATION =>
         Print (P.Indent, "   aggregate: " & Util.Beans.Objects.To_String (Value));

      when FIELD_ASSOCIATION_END_ID =>
         Print (P.Indent, "   end-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_NAME =>
         Print (P.Indent, "package " & Util.Beans.Objects.To_String (Value));
         P.Indent := P.Indent + 2;

      when FIELD_TAGGED_VALUE_VALUE =>
         Print (P.Indent, "-- " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAGGED_VALUE_TYPE =>
         Print (P.Indent, "tag-type: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_NAME =>
         Print (P.Indent, "Tag: " & Util.Beans.Objects.To_String (Value));

      when FIELD_TAG_DEFINITION_ID =>
         Print (P.Indent, "  tag-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_NAME =>
         Print (P.Indent, "Comment: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_BODY =>
         Print (P.Indent, "   text: " & Util.Beans.Objects.To_String (Value));

      when FIELD_COMMENT_CLASS_ID =>
         Print (P.Indent, "   for-id: " & Util.Beans.Objects.To_String (Value));

      when FIELD_PACKAGE_END | FIELD_CLASS_END | FIELD_ENUM_END | FIELD_ENUM_LITERAL_END |
           FIELD_ASSOCIATION_END =>
         P.Indent := P.Indent - 2;

      end case;
   end Set_Member;

   package XMI_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => XMI_Info,
                                               Element_Type_Access => XMI_Access,
                                               Fields              => XMI_Fields,
                                               Set_Member          => Set_Member);

   XMI_Mapping        : aliased XMI_Mapper.Mapper;

begin
--        Util.Log.Loggers.Initialize ("samples/log4j.properties");

   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: xmi file...");
      Ada.Text_IO.Put_Line ("Example xmi samples/demo-atlas.xmi");
      return;
   end if;

   --  Define the XMI mapping.
   XMI_Mapping.Add_Mapping ("**/Package/@name", FIELD_PACKAGE_NAME);
   XMI_Mapping.Add_Mapping ("**/Package/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Package", FIELD_PACKAGE_END);

   XMI_Mapping.Add_Mapping ("**/Class/@name", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.idref", FIELD_CLASS_NAME);
   XMI_Mapping.Add_Mapping ("**/Class/@xmi.id", FIELD_CLASS_ID);
   XMI_Mapping.Add_Mapping ("**/Class/@visibility", FIELD_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Class", FIELD_CLASS_END);

   XMI_Mapping.Add_Mapping ("**/Stereotype/@href", FIELD_STEREOTYPE);
   XMI_Mapping.Add_Mapping ("**/Stereotype/@name", FIELD_STEREOTYPE);

   XMI_Mapping.Add_Mapping ("**/Attribute/@name", FIELD_ATTRIBUTE_NAME);
   XMI_Mapping.Add_Mapping ("**/Attribute/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/TaggedValue.dataValue", FIELD_TAGGED_VALUE_VALUE);

   XMI_Mapping.Add_Mapping ("**/DataType/@href", FIELD_DATA_TYPE);

   XMI_Mapping.Add_Mapping ("**/Enumeration/@href", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration/@name", FIELD_ENUM_NAME);
   XMI_Mapping.Add_Mapping ("**/Enumeration", FIELD_ENUM_END);

   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral/@name", FIELD_ENUM_LITERAL);
   XMI_Mapping.Add_Mapping ("**/EnumerationLiteral", FIELD_ENUM_LITERAL_END);

   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@lower", FIELD_MULTIPLICITY_LOWER);
   XMI_Mapping.Add_Mapping ("**/MultiplicityRange/@upper", FIELD_MULTIPLICITY_UPPER);

   XMI_Mapping.Add_Mapping ("**/Operation/@name", FIELD_OPERATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Operation/@visibility", FIELD_VISIBILITY);

   XMI_Mapping.Add_Mapping ("**/Association/@name", FIELD_ASSOCIATION_NAME);
   XMI_Mapping.Add_Mapping ("**/Association/@visibility", FIELD_ASSOCIATION_VISIBILITY);
   XMI_Mapping.Add_Mapping ("**/Association/@aggregation", FIELD_ASSOCIATION_AGGREGATION);
   XMI_Mapping.Add_Mapping ("**/AssociationEnd.participant/Class/@xmi.idref",
                            FIELD_ASSOCIATION_END_ID);
   XMI_Mapping.Add_Mapping ("**/Association", FIELD_ASSOCIATION_END);

   XMI_Mapping.Add_Mapping ("**/TagDefinition/@name", FIELD_TAG_DEFINITION_NAME);
   XMI_Mapping.Add_Mapping ("**/TagDefinition/@xm.id", FIELD_TAG_DEFINITION_ID);

   XMI_Mapping.Add_Mapping ("**/Comment/@name", FIELD_COMMENT_NAME);
   XMI_Mapping.Add_Mapping ("**/Comment/@body", FIELD_COMMENT_BODY);
   XMI_Mapping.Add_Mapping ("**/Comment/Comment.annotatedElement/Class/@xmi.idref",
                            FIELD_COMMENT_CLASS_ID);

   Reader.Add_Mapping ("XMI", XMI_Mapping'Unchecked_Access);

   for I in 1 .. Count loop
      declare
         S    : constant String := Ada.Command_Line.Argument (I);
         Data : aliased XMI_Info;
      begin
         XMI_Mapper.Set_Context (Reader, Data'Unchecked_Access);
         Reader.Parse (S);
      end;
   end loop;
end XMI;

Update and fix the XMI example

Update and fix the XMI example


-----------------------------------------------------------------------
--  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.Test_Caller;
with Util.Measures;
with Util.Strings.Sets;

package body Security.OAuth.Clients.Tests is

   package Caller is new Util.Test_Caller (Test, "Security.OAuth.Clients");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Security.OAuth.Clients.Create_Nonce",
                       Test_Create_Nonce'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test Create_Nonce operation.
   --  ------------------------------
   procedure Test_Create_Nonce (T : in out Test) is
      Nonces : Util.Strings.Sets.Set;
   begin
      for I in 1 .. 1_000 loop
         for I in 32 .. 734 loop
            declare
               S : constant String := Create_Nonce (I * 3);
            begin
               T.Assert (not Nonces.Contains (S), "Nonce was not unique: " & S);
               Nonces.Include (S);
            end;
         end loop;
      end loop;
      declare
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               Nonce : constant String := Create_Nonce (128);
               pragma Unreferenced (Nonce);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (S, "128 bits nonce generation (1000 calls)");
      end;
   end Test_Create_Nonce;

end Security.OAuth.Clients.Tests;

Add unit tests for OAuth package and Create_Nonce operation


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                                                                          --
--     A S I S . A D A _ E N V I R O N M E N T S . C O N T A I N E R S      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (c) 1995-2006, 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.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

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

with Asis.Set_Get;           use  Asis.Set_Get;

with A4G.Contt;              use A4G.Contt;
with A4G.Vcheck;             use A4G.Vcheck;

package body Asis.Ada_Environments.Containers is

   Package_Name : constant String := "Asis.Ada_Environments.Containers.";

   --  At the moment, we implement the Container abstraction in a simplest
   --  possible way pointed out in section 9.1: any Context is mapped to
   --  a list of one Container
   --
   --  We think that the definition of the Container abstraction in ASIS
   --  contains a hole. The Container remains valid only till the Context
   --  from which it has been obtained remains opened (the same rule as for
   --  other ASIS abstractions - Compilation_Unit, Element, Line,
   --  Record_Component, Array_Component). We failed to find the corresponding
   --  rule in the ASIS Standard.

   -----------------------
   -- Local subprograms --
   -----------------------

   --  We can not put the access and update routines for the components of the
   --  Container type in Asis.Set_Get package where the access/update routines
   --  for other ASIS abstractions are defined, because the Container
   --  abstraction is defined not in Asis, but in
   --  Asis.Ada_Environments.Containers. If we decide to implement Containers
   --  in some non-trivial way, we may need to put low-level routines
   --  operating on Containers in some separate package

   function Set_Container
     (Cntnr : Container_Id;
      Cntxt : Context_Id)
      return Container;
   --  Creates the new value of the Container type, the Obtained field is set
   --  equal to the current ASIS OS time

   function Cntnr_Id (The_Container : Container) return Container_Id;
   function Encl_Cont_Id (The_Container : Container) return Context_Id;
   function Obtained     (The_Container : Container) return ASIS_OS_Time;
   --  These functions return components of the internal Contaier structure

   procedure Check_Validity
     (The_Container : Container;
      Query         : String);
   --  Checks if the argument does not belong to the closed (and possibly then
   --  reopened) Context. If this check fails, raises
   --  ASIS_Inappropriate_Container with Value_Error error status and forms
   --  the corresponding Diagnosis string

   function Is_Nil (The_Container : Container) return Boolean;
   --  Returns True if the container is a Nil_Container.
   --  This is really strange that we do not have this function in the spec.
   --  And the whole notion of Nil_Container seems to be ill-defined and
   --  as a result - useless.

   ------------------------------
   -- Local subprograms bodies --
   ------------------------------

   --------------------
   -- Check_Validity --
   --------------------

   procedure Check_Validity
     (The_Container : Container;
      Query         : String)
   is
   begin

      if not Is_Nil (The_Container) then

         if not Is_Opened (Encl_Cont_Id (The_Container)) or else
            not Later
                  (Opened_At (Encl_Cont_Id (The_Container)),
                   Obtained (The_Container))
         then
            Set_Error_Status
              (Status    => Value_Error,
               Diagnosis => "Invalid Container value in " & Query);

            raise ASIS_Inappropriate_Container;
         end if;

      end if;

   end Check_Validity;

   --------------
   -- Cntnr_Id --
   --------------

   function Cntnr_Id (The_Container : Container) return Container_Id is
   begin
      return The_Container.Id;
   end Cntnr_Id;

   ------------------
   -- Encl_Cont_Id --
   ------------------

   function Encl_Cont_Id (The_Container : Container) return Context_Id is
   begin
      return The_Container.Cont_Id;
   end Encl_Cont_Id;

   ------------
   -- Is_Nil --
   ------------

   function Is_Nil (The_Container : Container) return Boolean is
   begin
      return Cntnr_Id (The_Container) = Nil_Container_Id;
   end Is_Nil;

   --------------
   -- Obtained --
   --------------

   function Obtained (The_Container : Container) return ASIS_OS_Time is
   begin
      return The_Container.Obtained;
   end Obtained;

   -------------------
   -- Set_Container --
   -------------------

   function Set_Container
     (Cntnr : Container_Id;
      Cntxt : Context_Id)
      return  Container
   is
      Result_Container : Container := Nil_Container;
   begin

      if Cntnr /= Nil_Container_Id then
         Result_Container :=
           (Id       => Cntnr,
            Cont_Id  => Cntxt,
            Obtained => A_OS_Time);
      end if;

      return Result_Container;

   end Set_Container;

   -----------------------------------------
   -- End of the local subprograms bodies --
   -----------------------------------------

   -----------------------
   -- Compilation_Units --
   -----------------------

   function Compilation_Units
     (The_Container : Container)
      return          Asis.Compilation_Unit_List
   is
   begin

      Check_Validity (The_Container, Package_Name & "Compilation_Units");

      if Is_Nil (The_Container) then
         return Nil_Compilation_Unit_List;
      end if;

      return Compilation_Units (Enclosing_Context (The_Container));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Compilation_Units");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Compilation_Units",
            Ex          => Ex);
   end Compilation_Units;

   -----------------------------
   -- Compilation_Unit_Bodies --
   -----------------------------

   function Compilation_Unit_Bodies
     (The_Container : Container)
      return          Asis.Compilation_Unit_List
   is
   begin

      Check_Validity (The_Container, Package_Name & "Compilation_Unit_Bodies");

      if Is_Nil (The_Container) then
         return Nil_Compilation_Unit_List;
      end if;

      return Compilation_Unit_Bodies (Enclosing_Context (The_Container));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Compilation_Unit_Bodies");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Compilation_Unit_Bodies",
            Ex          => Ex);
   end Compilation_Unit_Bodies;

   -------------------------
   -- Defining_Containers --
   -------------------------

   function Defining_Containers
     (The_Context : Asis.Context)
      return        Container_List
   is
   begin

      Check_Validity (The_Context, Package_Name & "Defining_Containers");

      return
         (1 => Set_Container (First_Container_Id, Get_Cont_Id (The_Context)));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Defining_Containers");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Defining_Containers",
            Ex          => Ex);
   end Defining_Containers;

   -----------------------
   -- Enclosing_Context --
   -----------------------

   function Enclosing_Context
     (The_Container : Container)
      return          Asis.Context
   is
   begin

      Check_Validity (The_Container, Package_Name & "Enclosing_Context");

      if Is_Nil (The_Container) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => "Nil_Contaier in " & Package_Name
                                      & "Enclosing_Context");

         raise ASIS_Inappropriate_Container;
      end if;

      return Get_Cont (Encl_Cont_Id (The_Container));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Enclosing_Context");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Enclosing_Context",
            Ex          => Ex);
   end Enclosing_Context;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal
     (Left  : Container;
      Right : Container)
      return  Boolean
   is
   begin

      Check_Validity (Left,  Package_Name & "Is_Equal");
      Check_Validity (Right, Package_Name & "Is_Equal");

      return Is_Equal (Enclosing_Context (Left), Enclosing_Context (Right));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Is_Equal");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Is_Equal",
            Ex          => Ex);
   end Is_Equal;

   ------------------
   -- Is_Identical --
   ------------------

   function Is_Identical
     (Left  : Container;
      Right : Container)
      return  Boolean
   is
   begin

      Check_Validity (Left,  Package_Name & "Is_Identical");
      Check_Validity (Right, Package_Name & "Is_Identical");

      return Is_Equal (Left, Right) and then
             Is_Equal (Enclosing_Context (Left), Enclosing_Context (Right));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Is_Identical");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Is_Identical",
            Ex          => Ex);
   end Is_Identical;

   -------------------------------
   -- Library_Unit_Declarations --
   -------------------------------

   function Library_Unit_Declarations
     (The_Container : Container)
      return          Asis.Compilation_Unit_List
   is
   begin

      Check_Validity
        (The_Container, Package_Name & "Library_Unit_Declarations");

      if Is_Nil (The_Container) then
         return Nil_Compilation_Unit_List;
      end if;

      return Library_Unit_Declarations (Enclosing_Context (The_Container));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Library_Unit_Declarations");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Library_Unit_Declarations",
            Ex          => Ex);
   end Library_Unit_Declarations;

   ----------
   -- Name --
   ----------

   function Name
     (The_Container : Container)
      return          Wide_String
   is
   begin

      Check_Validity (The_Container, Package_Name & "Name");

      if Is_Nil (The_Container) then
         return Nil_Asis_Wide_String;
      end if;

      return Name (Enclosing_Context (The_Container));

   exception
      when ASIS_Inappropriate_Container =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Name");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Name",
            Ex          => Ex);
   end Name;

end Asis.Ada_Environments.Containers;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  security-auth-oauth -- OAuth based authentication
--  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 Security.OAuth.Clients;
private package Security.Auth.OAuth is

   --  ------------------------------
   --  OAuth Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OAuth authorization process.
   type Manager is abstract new Security.Auth.Manager with private;

   --  Initialize the authentication realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   overriding
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the OAuth access token and retrieve information about the user.
   procedure Verify_Access_Token (Realm   : in Manager;
                                  Assoc   : in Association;
                                  Request : in Parameters'Class;
                                  Token   : in Security.OAuth.Clients.Access_Token_Access;
                                  Result  : in out Authentication) is abstract;

private

   type Manager is abstract new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
      Scope     : Unbounded_String;
      App       : Security.OAuth.Clients.Application;
   end record;

end Security.Auth.OAuth;

Define the OAuth based authorization

Define the OAuth based authorization


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

package body Babel.Streams is

   --  ------------------------------
   --  Set the internal buffer that the stream can use.
   --  ------------------------------
   procedure Set_Buffer (Stream : in out Stream_Type;
                         Buffer : in Babel.Files.Buffers.Buffer_Access) is
   begin
      Stream.Buffer := Buffer;
   end Set_Buffer;

   --  ------------------------------
   --  Release the stream buffer if there is one.
   --  ------------------------------
   overriding
   procedure Finalize (Stream : in out Stream_Type) is
      use type Babel.Files.Buffers.Buffer_Access;
   begin
      if Stream.Buffer /= null then
         Babel.Files.Buffers.Release (Stream.Buffer);
      end if;
   end Finalize;

end Babel.Streams;

Implement the Set_Buffer and Finalize procedures


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--       A S I S . I M P L E M E N T A T I O N . P E R M I S S I O N S      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2007, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

package body Asis.Implementation.Permissions is

   ------------------------------
   -- Attributes_Are_Supported --
   ------------------------------

   function Attributes_Are_Supported return Boolean  is
   begin
      return False;
   end Attributes_Are_Supported;

   ------------------------------------------
   -- Call_Statement_Parameters_Normalized --
   ------------------------------------------

   function Call_Statement_Parameters_Normalized return Boolean is
   begin
      return False;
   end Call_Statement_Parameters_Normalized;

   -------------------------------
   -- Default_In_Mode_Supported --
   -------------------------------

   function Default_In_Mode_Supported return Boolean is
   begin
      return True;
   end Default_In_Mode_Supported;

   ------------------------------------------
   -- Discriminant_Associations_Normalized --
   ------------------------------------------

   function Discriminant_Associations_Normalized return Boolean  is
   begin
      return False;
   end Discriminant_Associations_Normalized;

   -----------------------------------------
   -- Function_Call_Parameters_Normalized --
   -----------------------------------------

   function Function_Call_Parameters_Normalized return Boolean is
   begin
      return False;
   end Function_Call_Parameters_Normalized;

   ------------------------------------
   -- Generic_Actual_Part_Normalized --
   ------------------------------------

   function Generic_Actual_Part_Normalized return Boolean is
   begin
      return False;
   end Generic_Actual_Part_Normalized;

   ---------------------------------------
   -- Generic_Macro_Expansion_Supported --
   ---------------------------------------

   function Generic_Macro_Expansion_Supported return Boolean is
   begin
      return True;
   end Generic_Macro_Expansion_Supported;

   -----------------------------------
   -- Implicit_Components_Supported --
   -----------------------------------

   function Implicit_Components_Supported return Boolean is
   begin
      return False;
   end Implicit_Components_Supported;

   --------------------------------------
   -- Inherited_Declarations_Supported --
   --------------------------------------

   function Inherited_Declarations_Supported return Boolean is
   begin
      return True;
   end Inherited_Declarations_Supported;

   -------------------------------------
   -- Inherited_Subprograms_Supported --
   -------------------------------------

   function Inherited_Subprograms_Supported return Boolean is
   begin
      return True;
   end Inherited_Subprograms_Supported;

   -----------------------------
   -- Is_Commentary_Supported --
   -----------------------------

   function Is_Commentary_Supported return Boolean is
   begin
      return True;
   end Is_Commentary_Supported;

   --------------------------------------------------
   -- Is_Formal_Parameter_Named_Notation_Supported --
   --------------------------------------------------

   function Is_Formal_Parameter_Named_Notation_Supported return Boolean is
   begin
      return True;
   end Is_Formal_Parameter_Named_Notation_Supported;

   ------------------------------
   -- Is_Line_Number_Supported --
   ------------------------------

   function Is_Line_Number_Supported return Boolean is
   begin
      return True;
   end Is_Line_Number_Supported;

   ------------------------------
   -- Is_Prefix_Call_Supported --
   ------------------------------

   function Is_Prefix_Call_Supported return Boolean is
   begin
      return True;
   end Is_Prefix_Call_Supported;

   ---------------------------------------
   -- Is_Span_Column_Position_Supported --
   ---------------------------------------

   function Is_Span_Column_Position_Supported return Boolean is
   begin
      return True;
   end Is_Span_Column_Position_Supported;

   ------------------------------------
   -- Object_Declarations_Normalized --
   ------------------------------------

   function Object_Declarations_Normalized return Boolean is
   begin
      return False;
   end Object_Declarations_Normalized;

   -------------------------------------
   -- Predefined_Operations_Supported --
   -------------------------------------

   function Predefined_Operations_Supported return Boolean is
   begin
      return False;
   end Predefined_Operations_Supported;

   ----------------------------------------------
   -- Record_Component_Associations_Normalized --
   ----------------------------------------------

   function Record_Component_Associations_Normalized return Boolean is
   begin
      return False;
   end Record_Component_Associations_Normalized;

end Asis.Implementation.Permissions;

Add the ASIS file $i

Add the ASIS file $i


------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--                          A S I S . C L A U S E S                         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 2006-2012, Free Software Foundation, Inc.       --
--                                                                          --
-- This   specification  is  adapted   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  In accordance --
-- with the copyright of that document, you can freely copy and modify this --
-- specification, provided that if you redistribute a modified version, any --
-- changes that you have made are clearly indicated.                        --
--                                                                          --
-- This  specification  also  contains  suggestions  and  discussion  items --
-- related to revising the  ASIS Standard according to the changes proposed --
-- for  the  new  revision of the Ada standard. The copyright notice above, --
-- and the license provisions that follow apply solely to these suggestions --
-- and  discussion  items  that  are separated by the corresponding comment --
-- sentinels                                                                --
--                                                                          --
-- 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  19 package Asis.Clauses

--  Suggestions related to changing this specification to accept new Ada
--  features as defined in incoming revision of the Ada Standard (ISO 8652)
--  are marked by following comment sentinels:
--
--  --|A2005 start
--   ... the suggestion goes here ...
--  --|A2005 end
--
--  and the discussion items are marked by the comment sentinels of teh form:
--
--  --|D2005 start
--   ... the discussion item goes here ...
--  --|D2005 end

------------------------------------------------------------------------------
------------------------------------------------------------------------------
package Asis.Clauses is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Clauses
--
--  This package encapsulates a set of queries that operate on A_Clause
--  elements.
--
--  --|ER---------------------------------------------------------------------
--  --|ER A_Use_Package_Clause  - 8.4
--  --|ER A_Use_Type_Clause     - 8.4
--  --|ER A_Use_All_Type_Clause - 8.4  --  Ada 2012
--  --|ER A_With_Clause         - 10.1.2
--  --|CR
--  --|CR Child elements returned by:
--  --|CR    function Clause_Names
--  --|CR
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  19.1  function Clause_Names
------------------------------------------------------------------------------

   function Clause_Names (Clause : Asis.Element) return Asis.Name_List;

------------------------------------------------------------------------------
--  Clause  - Specifies the with_clause or use_clause to query
--
--  Returns a list of the names that appear in the given clause.
--  The names in the list should be in their order of appearance in the
--  original clauses from the compilation text.
--
--  Results of this query may vary across ASIS implementations.  Some
--  implementations normalize all clauses containing multiple names
--  into an equivalent sequence of corresponding single clauses.
--  Similarly, an implementation may keep a name only once even though that
--  name can appear more than once in a clause.
--
--  Appropriate Element_Kinds:
--       A_Use_Package_Clause
--       A_Use_Type_Clause
--       A_Use_All_Type_Clause     --  Ada 2012
--       A_With_Clause
--
--  Returns Expression_Kinds:
--       An_Identifier
--       A_Selected_Component
--       An_Attribute_Reference
--
--  --|ER---------------------------------------------------------------------
--  --|ER A_Representation_Clause - 13.1
--  --|ER---------------------------------------------------------------------
--  --|ER An_Attribute_Definition_Clause - 13.3
--  --|ER An_Enumeration_Representation_Clause - 13.4
--  --|ER An_At_Clause - J.7
--  --|CR
--  --|CR Child elements returned by:
--  --|CR    function Representation_Clause_Name
--  --|CR    function Representation_Clause_Expression
--
------------------------------------------------------------------------------
--  19.2  function Representation_Clause_Name
------------------------------------------------------------------------------

   function Representation_Clause_Name
     (Clause : Asis.Clause)
      return   Asis.Name;

------------------------------------------------------------------------------
--  Clause  - Specifies the representation_clause to query
--
--  Returns the direct_name expression following the reserved word "for".
--
--  |D2005 start
--  But A_Component_Clause does not have the reserved word "for"! The wording
--  needs revising!
--  |D2005 end
--
--  Appropriate Clause_Kinds:
--       A_Representation_Clause
--       A_Component_Clause
--
--  Returns Expression_Kinds:
--       An_Identifier
--       An_Attribute_Reference
--
------------------------------------------------------------------------------
--  19.3  function Representation_Clause_Expression
------------------------------------------------------------------------------

   function Representation_Clause_Expression
     (Clause : Asis.Representation_Clause)
      return   Asis.Expression;

------------------------------------------------------------------------------
--  Clause  - Specifies the representation_clause to query
--
--  Returns the expression following the reserved word "use" or the reserved
--  words "use at".
--
--  Appropriate Representation_Clause_Kinds:
--       An_Attribute_Definition_Clause
--       An_Enumeration_Representation_Clause
--       An_At_Clause
--
--  Returns Element_Kinds:
--       An_Expression
--
--  --|ER---------------------------------------------------------------------
--  --|ER A_Record_Representation_Clause - 13.5.1
--  --|CR
--  --|CR Child elements returned by:
--  --|CR    function Representation_Clause_Name
--  --|CR    function Mod_Clause_Expression
--  --|CR    function Component_Clauses
--
------------------------------------------------------------------------------
--  19.4  function Mod_Clause_Expression
------------------------------------------------------------------------------

   function Mod_Clause_Expression
     (Clause : Asis.Representation_Clause)
      return   Asis.Expression;

------------------------------------------------------------------------------
--  Clause  - Specifies the record representation clause to query
--
--  Returns the static_expression appearing after the reserved words "at mod".
--
--  Returns a Nil_Element if a mod_clause is not present.
--
--  Appropriate Representation_Clause_Kinds:
--       A_Record_Representation_Clause
--
--  Returns Element_Kinds:
--       Not_An_Element
--       An_Expression
--
------------------------------------------------------------------------------
--  19.5  function Component_Clauses
------------------------------------------------------------------------------

   function Component_Clauses
     (Clause          : Asis.Representation_Clause;
      Include_Pragmas : Boolean := False)
      return            Asis.Component_Clause_List;

------------------------------------------------------------------------------
--  Clause          - Specifies the record representation clause to query
--  Include_Pragmas - Specifies whether pragmas are to be returned
--
--  Returns the component_clause and pragma elements from the
--  record_representation_clause, in their order of appearance.
--
--  Returns a Nil_Element_List if the record_representation_clause has no
--  component_clause or pragma elements.
--
--  Appropriate Representation_Clause_Kinds:
--       A_Record_Representation_Clause
--
--  Returns Element_Kinds:
--       A_Clause
--       A_Pragma
--
--  Returns Clause_Kinds:
--       A_Component_Clause
--
--  --|ER---------------------------------------------------------------------
--  --|ER A_Component_Clause - 13.5.1
--  --|CR
--  --|CR Child elements returned by:
--  --|CR    function Representation_Clause_Name
--  --|CR    function Component_Clause_Position
--  --|CR    function Component_Clause_Range
--
------------------------------------------------------------------------------
--  19.6  function Component_Clause_Position
------------------------------------------------------------------------------

   function Component_Clause_Position
     (Clause : Asis.Component_Clause)
      return   Asis.Expression;

------------------------------------------------------------------------------
--  Clause  - Specifies the component_clause to query
--
--  Returns the position expression for the component_clause.
--
--  Appropriate Clause_Kinds:
--       A_Component_Clause
--
--  Returns Element_Kinds:
--       An_Expression
--
------------------------------------------------------------------------------
--  19.7  function Component_Clause_Range
------------------------------------------------------------------------------

   function Component_Clause_Range
     (Clause : Asis.Component_Clause)
      return   Asis.Discrete_Range;

------------------------------------------------------------------------------
--  Clause  - Specifies the component_clause to query
--
--  Returns the first_bit .. last_bit range for the component_clause.
--
--  Appropriate Clause_Kinds:
--       A_Component_Clause
--
--  Returns Discrete_Range_Kinds:
--       A_Discrete_Simple_Expression_Range
--
------------------------------------------------------------------------------

end Asis.Clauses;

Add the ASIS file $i

Add the ASIS file $i


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

package body ASF.Filters.Cache_Control is

   --  ------------------------------
   --  The Do_Filter method of the Filter is called by the container each time
   --  a request/response pair is passed through the chain due to a client request
   --  for a resource at the end of the chain.  The <b>Cache_Control</b> filter adds
   --  a <tt>Cache-Control</tt>, <tt>Expires</tt>, <tt>Pragma</tt> and optionally a
   --  <tt>Vary</tt> header in the HTTP response.
   --  ------------------------------
   overriding
   procedure Do_Filter (F        : in Cache_Control_Filter;
                        Request  : in out Requests.Request'Class;
                        Response : in out Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
   begin
      if Length (F.Cache_Control_Header) > 0 then
         Response.Add_Header ("Cache-Control", To_String (F.Cache_Control_Header));
      end if;
      if Length (F.Vary) > 0 then
         Response.Add_Header ("Vary", To_String (F.Vary));
      end if;
      ASF.Servlets.Do_Filter (Chain    => Chain,
                              Request  => Request,
                              Response => Response);
   end Do_Filter;

   --  ------------------------------
   --  Called by the servlet container to indicate to a filter that the filter
   --  instance is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Cache_Control_Filter;
                         Config  : in ASF.Servlets.Filter_Config) is
   begin
      Server.Vary                 := Servlets.Get_Init_Parameter (Config, VARY_HEADER_PARAM);
      Server.Cache_Control_Header := Servlets.Get_Init_Parameter (Config, CACHE_CONTROL_PARAM);
   end Initialize;

end ASF.Filters.Cache_Control;

Implement the Cache_Control_Filter to add a Cache-Control and Vary header in the HTTP response


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . G N A T _ I N T                          --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2008, 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 contains the utility routines used for calling the GNAT
--  compiler from inside the ASIS implementation routines to create a tree
--  file.  These routines may be used by ASIS-based tools as well. The idea is
--  to call GNAT in a black-box manner. The current version of this package
--  borrows most of the ideas and the code patterns from the body of the
--  GNAT Make package (which defines the gnatmake-related routines).
--  Unfortunately, GNAT do not provide the public interface to these
--  routines, so we simply have copied the code from make.adb with some
--  modifications.
--
--  This package also contains the routine which reads the tree file with
--  checking the GNAT-ASIS versions compartibility.

with Ada.Calendar; use Ada.Calendar;

with A4G.A_Types;  use A4G.A_Types;
with A4G.A_Debug;

with GNAT.OS_Lib;  use GNAT.OS_Lib;
with Types;        use Types;

package A4G.GNAT_Int is

   -----------------------------------
   -- Compiler Variables & Routines --
   -----------------------------------

   Nul_Argument_List : constant Argument_List (1 .. 0) := (others => null);

   --  The flags listed below are used to form the appropriate GNAT or
   --  gnatmake call to create the tree file

   Comp_Flag    : constant String_Access := new String'("-c");

   GNAT_Flag    : constant String_Access := new String'("-gnatg");
   GNAT_Flag_ct : constant String_Access := new String'("-gnatct");
   GNAT_Flag_t  : constant String_Access := new String'("-gnatt");
   GNAT_Flag_ws : constant String_Access := new String'("-gnatws");
   GNAT_Flag_yN : constant String_Access := new String'("-gnatyN");
   GNAT_Flag_05 : constant String_Access := new String'("-gnat05");

   GCC_Flag_X   : constant String_Access := new String'("-x");
   GCC_Par_Ada  : constant String_Access := new String'("ada");
   GCC_Flag_o   : constant String_Access := new String'("-o");

   GNATMAKE_Flag_q     : constant String_Access := new String'("-q");
   GNATMAKE_Flag_u     : constant String_Access := new String'("-u");
   GNATMAKE_Flag_f     : constant String_Access := new String'("-f");
   GNATMAKE_Flag_cargs : constant String_Access := new String'("-cargs");

--   Display_Executed_Programs : Boolean renames A4G.A_Debug.Debug_Mode;
   --  Set to True if name of commands should be output on stderr.
   --  Now this flag is toughtly binded with the flag setting the
   --  ASIS Debug Mode. Is it a good decision?

   function Execute
     (Program      : String_Access;
      Args         : Argument_List;
      Compiler_Out : String := "";
      Display_Call : Boolean := A4G.A_Debug.Debug_Mode)
      return         Boolean;
   --  Executes Program. If the program is not set (the actual for Program is
   --  null), executes the gcc command Args contains the arguments to be passed
   --  to Program. If the program is executed successfully True is returned.
   --
   --  If Compiler_Out is a non-empty string, this string is treated as the
   --  name of a text file to redirect the compiler output into (if the file
   --  does not exist, it is created). Othervise the compiler output is
   --  sent to Stderr.
   --
   --  If Display_Call is ON, outputs into Stderr the command used to execure
   --  Program.

   procedure Create_Tree (Source_File   :     String_Access;
                          Context       :     Context_Id;
                          Is_Predefined :     Boolean;
                          Success       : out Boolean);
   --  Tries to create the tree output file for the given source file
   --  in the context of a given Context. Uses the "standard" GNAT
   --  installation to do this

   procedure Tree_In_With_Version_Check
     (Desc    : File_Descriptor;
      Cont    : Context_Id;
      Success : out Boolean);
   --  Desc is the file descriptor for the file containing the tree file
   --  created by the compiler, Cont is the Id of the Context this tree is
   --  supposed to belong to. This routine reads in the content of the tree
   --  file and makes the GNAT-ASIS version check as a part of tree reading.
   --  If the version check fails or if any error corresponding to the problems
   --  with the expected tree format is detected, Program_Error is raised with
   --  the exception message "Inconsistent versions of GNAT and ASIS". If
   --  the tree can not be read in because of any other reason (for example,
   --  it is not compile-only), the Success parameter is set OFF and the
   --  continuation depends on the Context parameters. If the tree has been
   --  read in successfully and if it is compile-only, Success is set ON.
   --
   --  Before calling this procedure, a caller should put the name of the tree
   --  file to read into A_Name_Buffer.
   --
   --  NOTE: the procedure always closes Desc before returning. Closing it
   --  the second time is erroneous.

   function A_Time (T : Time_Stamp_Type)
      return Time;
   --  Converts GNAT file time stamp into the corresponding value
   --  of Asis_Time.

end A4G.GNAT_Int;

Add the ASIS file $i

Add the ASIS file $i


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

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

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

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

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

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

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

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

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

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

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

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

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

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

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

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

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

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

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

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

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

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

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

private

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

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

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

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

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

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

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

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

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

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

   end Interface_P;

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

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

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

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

end Util.Properties;

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

   NO_PROPERTY : exception;

   use Ada.Strings.Unbounded;

   subtype Value is Ada.Strings.Unbounded.Unbounded_String;

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

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

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

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

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

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

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

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

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

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

   --  Insert the specified property in the list.
   procedure Insert (Self : in out Manager'Class;
                     Name : in String;
                     Item : in String);

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

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

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

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

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

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

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

   --  Load the properties from the file input stream.  The file must follow
   --  the definition of Java property files.
   procedure Load_Properties (Self : in out Manager'Class;
                              File : in Ada.Text_IO.File_Type);

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

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

private

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

      type Manager is abstract tagged limited record
         Count : Natural := 0;
      end record;
      type Manager_Access is access all Manager'Class;

      type Manager_Factory is access function return Manager_Access;

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

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

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

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

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

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

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

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

   end Interface_P;

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

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

   type Manager is new Ada.Finalization.Controlled with record
      Impl : Interface_P.Manager_Access := null;
   end record;

   overriding
   procedure Adjust   (Object : in out Manager);

   overriding
   procedure Finalize (Object : in out Manager);

end Util.Properties;

Adjust and Finalize are overriding

Adjust and Finalize are overriding


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--          A S I S . C O M P I L A T I O N _ U N I T S . T I M E S         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2008, 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.Exceptions; use Asis.Exceptions;
with Asis.Errors;     use Asis.Errors;

with Asis.Set_Get;    use Asis.Set_Get;

with A4G.Vcheck;      use A4G.Vcheck;

package body Asis.Compilation_Units.Times is

   Package_Name : constant String := "Asis.Compilation_Units.Times.";

   Standard_Time : constant Ada.Calendar.Time :=
      Ada.Calendar.Time_Of (1994, 12, 21, 0.0);
   --  used as Time_Of_Last_Update for the predefined Standard package

   --------------------
   -- Attribute_Time --
   --------------------

   function Attribute_Time
     (Compilation_Unit : Asis.Compilation_Unit;
      Attribute        : Wide_String)
      return             Ada.Calendar.Time
   is
   begin
      pragma Unreferenced (Attribute);

      Check_Validity (Compilation_Unit, Package_Name & "Attribute_Time");

      return Nil_ASIS_Time;
   end Attribute_Time;

   ------------------------------
   -- Compilation_CPU_Duration --
   ------------------------------

   function Compilation_CPU_Duration
     (Compilation_Unit : Asis.Compilation_Unit)
      return             Standard.Duration
   is
   begin
      Check_Validity
        (Compilation_Unit, Package_Name & "Compilation_CPU_Duration");

      return 0.0;
   end Compilation_CPU_Duration;

   -------------------------
   -- Time_Of_Last_Update --
   -------------------------

   function Time_Of_Last_Update
     (Compilation_Unit : Asis.Compilation_Unit)
      return             Ada.Calendar.Time
   is
   begin
      Check_Validity (Compilation_Unit, Package_Name & "Time_Of_Last_Update");

      if Get_Unit_Id (Compilation_Unit) = Standard_Id then

         return Standard_Time;
      else

         return Time_Stamp (Compilation_Unit);
      end if;

   exception
      when ASIS_Inappropriate_Compilation_Unit =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Time_Of_Last_Update");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Time_Of_Last_Update",
            Ex         => Ex,
            Arg_CU     => Compilation_Unit);
   end Time_Of_Last_Update;

end Asis.Compilation_Units.Times;

Add the ASIS file $i

Add the ASIS file $i


Add the ASIS file $i

Add the ASIS file $i