------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                            A 4 G . V C H E C K                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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).                                                --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Exceptions; use Ada.Exceptions;

with Asis;           use Asis;
with Asis.Text;      use Asis.Text;
with Asis.Errors;    use Asis.Errors;

with A4G.A_Types;    use A4G.A_Types;
with A4G.Int_Knds;   use A4G.Int_Knds;

--  This package contains the routines for checking the validity of the
--  arguments of the ASIS queries and for generating the diagnostic info.
--  This package in its current state originated from the very beginning of
--  the ASIS project and it definitely needs revising.

package A4G.Vcheck is

--  GNAT-style reformatting required!! Only formal compatibility with -gnatg
--  is achieved by now.

--  This package contains procedures for checking the validity of the
--  Context, Compilation_Unit and Element values, raising the
--  Asis-defined exceptions (with previous setting of the status
--  value and forming the Diagnosis string) in some standard
--  situations and utility subprograms to be used in the keeping to
--  the "catch-all" policy defined in the subsection 3.6 of the
--  ASIS: Detailed Semantics and Implementation Document (v. 1.1.1)
--
--  The first prototype implementation uses rather roof approach
--  to keep to the "catch-all" policy in respect to the
--  non-Asis-defined exceptions and to handle the status and Diagnosis
--  information. The main principles of this approach are:
--
--  (a) all non-Asis exceptions are caught by
--
--        when others =>
--          Raise_ASIS_Failed (Diagnosis => "Name of the routine in which"
--                             &" this handler is" );
--
--       exception handler, and as a rule no attempt is undertaken
--       to recover from the error situation (Status is set as
--       "Value_Error" and ASIS_Failed is raised);
--
--  (b) Diagnosis string contains only general description of the failure
--      and the indication of the Asis query or low-level implementation
--      utility subprogram in which the Asis-defined exception was initially
--      raised;
--
--  (c) if Asis-defined exception propagates through the Asis implementation,
--      then the information related to the dynamic context of the exception
--      propagation is added to the Diagnosis (and separated by the
--      Asis_Types_And_Limits.ASIS_Line_Terminator constant).
--
--  (d) most of the routines in the Asis implementation should contain the
--      exception handler with the "others" choice (as described in the
--      paragraph (a) above. If it is known that the Asis_defined exception
--      could be raised in the procedure or function body, then the body
--      should contain two following exception handlers in the order given:
--
--      when Asis_ASIS_Inappropriate_Context    |
--          ASIS_Inappropriate_Compilation_Unit |
--          ASIS_Inappropriate_Element            =>
--
--          raise; -- nothing should be done additionally;
--                 -- exception has been raised in the argument(s)
--                 -- validity/appropriation checks in the same
--                 -- frame
--
--      when ASIS_Failed -- | other possible Asis-defined exceptions
--                           =>
--        Add_Call_Information (Outer_Call => "Name of the routine in which"
--                           &" this handler is" );
--        raise; ---????????
--
--      when others =>
--        Raise_ASIS_Failed (Diagnosis => "Name of the routine in which"
--                           &" this handler is" );
--

   procedure Add (Phrase : String);
   --  Adds Phrase to Diagnosis_Buffer and resets Diagnosis_Len. Exits with no
   --  (further) change in Diagnosis_Buffer as soon as Diagnosis_Len attains
   --  Max_Diagnosis_Length.

   ------------------------------------------------------------
   --  Checking the validity of Context, Compilation_Unit and
   --  Element
   ------------------------------------------------------------

------------------------------------------------------------
   procedure Check_Validity
     (Compilation_Unit : Asis.Compilation_Unit;
      Query            : String);
------------------------------------------------------------
--   Compilation_Unit - Specifies the unit to check
--   Query            - Specifies the name of query in which the check
--                      is performed. The parameter value is used to
--                      form the Diagnosis string
--
--  Performs the check if the unit does not belong to the closed library
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
---------------------------------------------------------------
   procedure Check_Validity
     (Element : Asis.Element;
      Query   : String);
------------------------------------------------------------
--   Element - Specifies the element to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the element does not belong to the invalid
--  element
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
---------------------------------------------------------------
   procedure Check_Validity (Line  : Asis.Text.Line;
                             Query : String);
------------------------------------------------------------
--   Line    - Specifies the Line to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the line does not belong to the invalid
--   Context
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!
------------------------------------------------------------
   procedure Check_Validity (Context : Asis.Context;
                             Query   : String);
------------------------------------------------------------
--   Context - Specifies the ASIS Context to check
--   Query   - Specifies the name of query in which the check is performed.
--             The parameter value is used to form the Diagnosis string
--
--  Performs the check if the Context is not in inassosiated or inopened
--  state
--  Sets the corresponding Status and forms the corresponding Diagnosis
--  if the check fails
--
--  BETTER DOCS NEEDED!!

   -------------------------------------
   -- Raising Asis-defined exceptions --
   -------------------------------------

   procedure Raise_ASIS_Failed
     (Diagnosis    : String;
      Argument     : Asis.Element            := Nil_Element;
      Stat         : Asis.Errors.Error_Kinds := Internal_Error;
      Bool_Par     : Boolean                 := False;
      Internal_Bug : Boolean := True);
   --  Raises ASIS_Failed with Stat as the value of ASIS Error Status.
   --  Usually expects the query name as Diagnosis. If the corresponding ASIS
   --  standard query has an optional boolean parameter, and if this parameter
   --  is set on for the given call to this query, then Bool_Par is expected to
   --  be set True. Internal_Bug specifies if the procedure is called for an
   --  internal implementation bug.
   --  This routine may be used to raise ASIS_Failed not only for the cases of
   --  internal implementation errors. In this case Internal_Bug should be set
   --  OFF, and Stat should specify the error kind.
   --  If Argument is not IS_Nil, adds the debug image of the argument to the
   --  diagnosis string.

   procedure Raise_ASIS_Failed_In_Traversing
     (Start_Element  : Asis.Element;
      Failure_At     : Asis.Element;
      Pre_Op         : Boolean;
      Exception_Info : String);
   --  Raises ASIS_Failed with Stat as Unhandled_Exception_Error for the
   --  situation  when some non-ASIS exception is raised in actual Pre-
   --  (Pre-Op is set ON) or Post-Operation (Pre_Op is set False). If forms the
   --  diagnostic message indicating the starting Element of the traversal
   --  (should be provided as the actual for Start_Element), the Element for
   --  which the failure took place (actual for Failure_At) and the information
   --  about the exception raised (passed as Exception_Info)

--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Compilation_Unit
                         (Diagnosis : String);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query to which the Compilation Unit
--              with inappropriate kind was passed
--
--  Raises ASIS_Inappropriate_Compilation_Unit with Value_Error status
--
--  BETTER DOCS NEEDED!!
--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Element
     (Diagnosis  : String;
      Wrong_Kind : Internal_Element_Kinds;
      Status     : Error_Kinds      := Value_Error);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query to which the Element with
--              inappropriate kind was passed
--
--  Raises ASIS_Inappropriate_Element with Status error status
--
--  BETTER DOCS NEEDED!!
--
--------------------------------------------------------------------
   procedure Raise_ASIS_Inappropriate_Line_Number
     (Diagnosis : String;
      Status    : Error_Kinds      := Value_Error);
--------------------------------------------------------------------
   procedure Not_Implemented_Yet (Diagnosis : String);
--------------------------------------------------------------------
--  Diagnosis - Specifies the query which has not been implemented
--              properly yet and has a placeholder as its body
--
--  Raises ASIS_Failed with Not_Implemented_Error status
--
--  This procedure is used in the placeholder bodies of the non-implemented
--  queries
--
--  BETTER DOCS NEEDED!!
--------------------------------------------------------------------

   ----------------------------------------------
   --  Setting the Status and Diagnosis values --
   ----------------------------------------------

--------------------------------------------------------------------
   procedure Set_Error_Status
     (Status    : Error_Kinds      := Not_An_Error;
      Diagnosis : String := Nil_Asis_String);
--------------------------------------------------------------------
--
--  This procedure is the full analog of the A4G.Set_Status
--  procedure, it is intended to be used as the implementation of the
--  A4G.Set_Status (by means of the renaming_as_a_body
--  in the body of Asis_Environment)
--------------------------------------------------------------------

   -----------------------------
   -- Adding Call Information --
   -----------------------------

   procedure Add_Call_Information
     (Outer_Call : String;
      Argument   : Asis.Element := Nil_Element;
      Bool_Par   : Boolean := False);
   --  Adds in the ASIS diagnosis the information about dynamically enclosing
   --  calls when an ASIS exception is propagated from some dynamically
   --  enclosed routine. If Argument is not Nil, adds its debug image in the
   --  Diagnosis, if needed (that is, if Argument_Postponed flag is set on,
   --  and resets this flag OFF after that)

   pragma No_Return (Raise_ASIS_Failed);
   pragma No_Return (Raise_ASIS_Inappropriate_Compilation_Unit);
   pragma No_Return (Raise_ASIS_Inappropriate_Element);
   pragma No_Return (Not_Implemented_Yet);

   -------------------------------------------
   -- The revised code is below this header --
   -------------------------------------------

   ---------------------------------------------------------------------
   -- Data Objects for Handling the Diagnosis string and Error Status --
   ---------------------------------------------------------------------

   Status_Indicator : Error_Kinds := Not_An_Error;

   Diagnosis_Buffer : String (1 .. Max_Diagnosis_Length);
   Diagnosis_Len    : Natural range 0 .. Max_Diagnosis_Length := 0;
   --  The string buffer to form ASIS Diagnosis

   ---------------------------
   --  ASIS Error handling  --
   ---------------------------

   --  The following documentation item should be revised when the revising of
   --  the ASIS exception handling is completed (BB14-010)

   --  According to the ASIS Standard, only ASIS-defined exceptions are allowed
   --  to be raised by ASIS queries.
   --
   --  The semantics of ASIS_Inappropriate_*** expectations well-defined and is
   --  supposed to be implemented in full conformance with ASIS Standard
   --  requirements.
   --
   --  According to  Asis.Exceptions, ASIS_Failed is "is a catch-all exception
   --  that may be raised for different reasons in different ASIS
   --  implementations".
   --
   --  We are using the following approach to handing and reporting the
   --  internal implementation errors and to raising ASIS_Failed.
   --
   --  1. According to the (rather ill-defined) requirement of the ASIS
   --     Standard and other documents generated during the ASIS
   --     standardization process (in particular, "ASIS: Detailed Semantics and
   --     Implementation. Ada Semantic Interface Specification. ASIS version
   --     1.1.1. April 26, 1994 by Gary E. Barnes), the body of every ASIS
   --     query contains 'when OTHERS' exception handler which does not allow
   --     any non-ASIS exception to propagate out of any ASIS query. (The
   --     exception is a set of rather trivial bodies of ASIS queries for which
   --     raising of non-ASIS exceptions is practically impossible).
   --
   --  2. By default any unexpected exception raise (that is, raising of any
   --     non-ASIS exception because of any reason) is treated as ASIS
   --     implementation error which should be immediately reported and which
   --     does not allow to continue the execution of any ASIS application.
   --     That is, detection of such an error should result in immediate exit
   --     to OS. This is implemented as the default behavior of all the ASIS
   --     and ASIS extensions queries.
   --
   --  3. An application may want to continue its execution even in case when
   --     an internal ASIS implementation error is detected. (The reason could
   --     be to try to use some workarounds for known ASIS implementation
   --     problems and to get the required information by some other ways).
   --     For this the application may set the Keep_Going flag ON by setting
   --     '-k' parameter of Asis.Implementation.Initialize. As a result,
   --     instead of generating the exit to OS, ASIS_Failed is raised with
   --     Unhandled_Exception_Error status.
   --
   --  4. We have some other reasons for raising ASIS_Failed. It can be raised
   --     in case when ASIS is initialized with "treat ASIS warnings as errors"
   --     mode as a part of generating of the ASIS warning. We have to use
   --     ASIS_Failed here, because the ASIS Standard does not give us any
   --     other choice. ASIS_Failed may also be raised by queries from
   --     Asis.Compilation_Units which are not supposed to be used for a
   --     dynamic Context. The important thing is that when ASIS_Failed is
   --     raised as a result of ASIS warning, the Error Status can never be
   --     Unhandled_Exception_Error
   --
   --  5. The general approach to exception handling in our ASIS implementation
   --     is:
   --
   --     - For every standard ASIS query and for every ASIS Extensions query
   --       which is not trivial enough to conclude that raising of any
   --       non-ASIS exception is practically impossible, the body of this
   --       query should contain "when EX : OTHERS' handler, and the only
   --       statement in this handler should be the call to Report_ASIS_Bug
   --       procedure (see the documentation of this procedure below)
   --
   --     - For every standard ASIS query and for every ASIS Extensions query
   --       which is not trivial enough to conclude that generating of the ASIS
   --       failure is practically impossible or for which we can not be sure
   --       that its implementation does not use any other ASIS queries, the
   --       body of this query should contain the handler for ASIS_Failed with
   --       the following code
   --
   --          when ASIS_Failed =>
   --             is Status_Indicator = Unhandled_Exception_Error then
   --                Add_Call_Information (...)
   --             end if;
   --
   --             raise;
   --
   --     The idea in behind is: if ASIS_Failed is the result of the internal
   --     ASIS implementation bug (that is, unexpected exception suppressed),
   --     we are collecting the information of enclosing calls, this may be
   --     useful if the call to one ASIS query is used in the implementation
   --     of some other ASIS query, the full "trace" of calls of the ASIS
   --     queries may be useful for an ASIS application programmer if (s)he
   --     would like to provide protections for ASIS bugs and to use some
   --     workarounds. And if ASIS_Failed is a result of ASIS warning, it
   --     should just propagated out of ASIS with the Diagnosis string formed
   --     as a part of error generation. ASIS_Failed raised when calling
   --     Asis.Compilation_Units queries which can not be used for a dynamic
   --     context could never be raised inside the call to an ASIS query
   --     enclosed into a call to some other ASIS query.

   procedure Report_ASIS_Bug
     (Query_Name    : String;
      Ex            : Exception_Occurrence;
      Arg_Element   : Asis.Element          := Nil_Element;
      Arg_Element_2 : Asis.Element          := Nil_Element;
      Arg_CU        : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_CU_2      : Asis.Compilation_Unit := Nil_Compilation_Unit;
      Arg_Line      : Asis.Text.Line        := Nil_Line;
      Arg_Span      : Asis.Text.Span        := Nil_Span;
      Bool_Par_ON   : Boolean               := False;
      Context_Par   : Boolean               := False
      --  What else???
      );
   pragma No_Return (Report_ASIS_Bug);
   --  This procedure is supposed to be called in "when OTHERS" exception
   --  handlers of an ASIS queries only. If we are in such an exception
   --  handler, then for sure we have detected some ASIS implementation bug.
   --  Depending on the ASIS initialization options, this procedure may
   --  perform the following options:
   --
   --  - generates the ASIS bug box similar to the GNAT bug box generated by
   --    the GNAT Comperr.Compiler_Abort procedure.
   --
   --  - raises ASIS_Failed with the summary of the information which should
   --    go into the ASIS bug box as the ASIS Diagnosis string
   --
   --  - causes the exit to OS.
   --
   --  Either exit to OS or raising ASIS_Failed should take place in any case.
   --  In case of exit to OS, the ASIS bug box should be generated.
   --
   --  The call to this procedure should never result in exception raise (other
   --  then raising ASIS_Failed by purpose), the worst case is that the
   --  diagnostic information formed by this procedure is incomplete.
   --
   --  Query_Name should be set to the full expanded Ada name of the query
   --  where this procedure is called
   --
   --  Ex should be the exception name form enclosing "when Ex : others"
   --  handlers.
   --
   --  All the other parameters are used to compose some debug information
   --  about the parameters of the call which fails. Some ASIS queries have
   --  two Element or Compilation Unit parameters, that's why we need
   --  Arg_Element_2 and Arg_CU_2. For queries having only one Element or CU
   --  parameter, Arg_Element or Arg_CU should be used to pass the argument of
   --  the call to form the diagnostic info.

end A4G.Vcheck;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  security-auth-oauth-facebook -- Facebook 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 Util.Beans.Objects;
with Util.Beans.Objects.Time;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Http.Rest;
package body Security.Auth.OAuth.Facebook is

   --
   TIME_SHIFT : constant Duration := 12 * 3600.0;

   type Token_Info_Field_Type is (FIELD_APP_ID, FIELD_IS_VALID,
                                  FIELD_EXPIRES, FIELD_ISSUED_AT,
                                  FIELD_USER_ID, FIELD_EMAIL, FIELD_FIRST_NAME,
                                  FIELD_LAST_NAME, FIELD_NAME, FIELD_LOCALE, FIELD_GENDER);

   type Token_Info is record
      App_Id     : Ada.Strings.Unbounded.Unbounded_String;
      Is_Valid   : Boolean := False;
      Expires    : Ada.Calendar.Time;
      Issued     : Ada.Calendar.Time;
      User_Id    : Ada.Strings.Unbounded.Unbounded_String;
      Email      : Ada.Strings.Unbounded.Unbounded_String;
      Name       : Ada.Strings.Unbounded.Unbounded_String;
      First_Name : Ada.Strings.Unbounded.Unbounded_String;
      Last_Name  : Ada.Strings.Unbounded.Unbounded_String;
      Locale     : Ada.Strings.Unbounded.Unbounded_String;
      Gender     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Token_Info_Access is access all Token_Info;

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

   procedure Set_Member (Into  : in out Token_Info;
                         Field : in Token_Info_Field_Type;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_APP_ID =>
            Into.App_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_IS_VALID =>
            Into.Is_Valid := Util.Beans.Objects.To_Boolean (Value);

         when FIELD_EXPIRES =>
            Into.Expires := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_ISSUED_AT =>
            Into.Issued := Util.Beans.Objects.Time.To_Time (Value);

         when FIELD_USER_ID =>
            Into.User_Id := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_EMAIL =>
            Into.Email := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_NAME =>
            Into.Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_FIRST_NAME =>
            Into.First_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LAST_NAME =>
            Into.Last_Name := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_LOCALE =>
            Into.Locale := Util.Beans.Objects.To_Unbounded_String (Value);

         when FIELD_GENDER =>
            Into.Gender := Util.Beans.Objects.To_Unbounded_String (Value);

      end case;
   end Set_Member;

   package Token_Info_Mapper is
      new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Token_Info,
                                                Element_Type_Access => Token_Info_Access,
                                                Fields              => Token_Info_Field_Type,
                                                Set_Member          => Set_Member);

   procedure Get_Token_Info is
     new Util.Http.Rest.Rest_Get (Element_Mapper => Token_Info_Mapper);

   Token_Info_Map : aliased Token_Info_Mapper.Mapper;

   --  ------------------------------
   --  Verify the OAuth access token and retrieve information about the user.
   --  ------------------------------
   overriding
   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
      use type Ada.Calendar.Time;

      T    : constant String := Token.Get_Name;
      Info : aliased Token_Info;
      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Get_Token_Info ("https://graph.facebook.com/debug_token?access_token=" & T
                      & "&input_token=" & T,
                      Token_Info_Map'Access,
                      "/data",
                      Info'Unchecked_Access);
      if not Info.Is_Valid then
         Set_Result (Result, INVALID_SIGNATURE, "invalid access token returned");

      elsif Info.Issued + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token issued more than 1 hour ago");

      elsif Info.Expires + TIME_SHIFT < Now then
         Set_Result (Result, INVALID_SIGNATURE, "the access token has expored");

      elsif Length (Info.User_Id) = 0 then
         Set_Result (Result, INVALID_SIGNATURE, "the access token refers to an empty user_id");

      elsif Info.App_Id /= Realm.App.Get_Application_Identifier then
         Set_Result (Result, INVALID_SIGNATURE,
                     "the access token was granted for another application");

      else
         Result.Identity := To_Unbounded_String ("https://graph.facebook.com/");
         Append (Result.Identity, Info.User_Id);
         Result.Claimed_Id := Result.Identity;

         Get_Token_Info ("https://graph.facebook.com/" & To_String (Info.User_Id)
                           & "?access_token=" & T,
                         Token_Info_Map'Access,
                         "",
                         Info'Unchecked_Access);

         Result.Email      := Info.Email;
         Result.Full_Name  := Info.Name;
         Result.First_Name := Info.First_Name;
         Result.Last_Name  := Info.Last_Name;
         Result.Language   := Info.Locale;
         Result.Gender     := Info.Gender;
         Set_Result (Result, AUTHENTICATED, "authenticated");
      end if;
   end Verify_Access_Token;

begin
   Token_Info_Map.Add_Mapping ("app_id", FIELD_APP_ID);
   Token_Info_Map.Add_Mapping ("expires_at", FIELD_EXPIRES);
   Token_Info_Map.Add_Mapping ("issued_at", FIELD_ISSUED_AT);
   Token_Info_Map.Add_Mapping ("is_valid", FIELD_IS_VALID);
   Token_Info_Map.Add_Mapping ("user_id", FIELD_USER_ID);
   Token_Info_Map.Add_Mapping ("email", FIELD_EMAIL);
   Token_Info_Map.Add_Mapping ("name", FIELD_NAME);
   Token_Info_Map.Add_Mapping ("first_name", FIELD_FIRST_NAME);
   Token_Info_Map.Add_Mapping ("last_name", FIELD_LAST_NAME);
   Token_Info_Map.Add_Mapping ("locale", FIELD_LOCALE);
   Token_Info_Map.Add_Mapping ("gender", FIELD_GENDER);
end Security.Auth.OAuth.Facebook;

Implement the Facebook authentication

Implement the Facebook authentication


-- RUN: %llvmgcc -c %s
with System;
procedure Negative_Field_Offset (N : Integer) is
   type String_Pointer is access String;
   --  Force use of a thin pointer.
   for String_Pointer'Size use System.Word_Size;
   P : String_Pointer;
begin
   P := new String (1 .. N);
end;

Test handling of record fields with negative offsets.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@84851 91177308-0d34-0410-b5e6-96231b3b80d8


-- t0017.adb - Tue Jan  7 19:31:46 2014
--
-- (c) Warren W. Gay VE3WWG  ve3wwg@gmail.com
--
-- Protected under the following license:
-- GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999

with Ada.Text_IO;

with Posix;
use Posix;

procedure T0017 is
   use Ada.Text_IO;

   Path :      constant String := "Test_0017";
   Fd :        fd_t;
   Old_Mask :  mode_t;
   S :         s_stat;
   Error :     errno_t;
   Times :     s_utimbuf;
begin

   Put_Line("Test 0017 - Chmod/FChmod");

   pragma Warnings(Off);
   Unlink(Path,Error);           -- Ignore errors
   pragma Warnings(On);

   Create(Path,8#666#,Fd,Error);
   pragma Assert(Error = 0);
   pragma Assert(Fd >= 0);

   UMask(8#111#,Old_Mask,Error);
   pragma Assert(Error = 0);

   Chmod(Path,8#777#,Error);
   pragma Assert(Error = 0);

   Stat(Path,S,Error);
   pragma Assert(Error = 0);
   pragma Assert(S.st_mode = 8#666#);

   FChmod(Fd,8#444#,Error);
   pragma Assert(Error = 0);

   Stat(Path,S,Error);
   pragma Assert(Error = 0);
   pragma Assert(S.st_mode = 8#444#);

   UMask(Old_Mask,Old_Mask,Error);
   pragma Assert(Error = 0);
   pragma Assert(Old_Mask = 8#111#);

   Unlink(Path,Error);
   pragma Assert(Error = 0);

   Put_Line("Test 0017 Passed.");

end T0017;

Test 17 for Chmod/FChmod

Test 17 for Chmod/FChmod


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

   --  ------------------------------
   --  Set the output writer.
   --  ------------------------------
   procedure Set_Writer (Document : in out Text_Renderer;
                         Writer   : in Wiki.Writers.Writer_Type_Access) is
   begin
      Document.Writer := Writer;
   end Set_Writer;

   --  ------------------------------
   --  Add a section header in the document.
   --  ------------------------------
   overriding
   procedure Add_Header (Document : in out Text_Renderer;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive) is
      pragma Unreferenced (Level);
   begin
      Document.Close_Paragraph;
      if not Document.Empty_Line then
         Document.Add_Line_Break;
      end if;
      Document.Writer.Write (Header);
      Document.Add_Line_Break;
   end Add_Header;

   --  ------------------------------
   --  Add a line break (
).
   --  ------------------------------
   overriding
   procedure Add_Line_Break (Document : in out Text_Renderer) is
   begin
      Document.Writer.Write (Ada.Characters.Conversions.To_Wide_Wide_Character (ASCII.LF));
      Document.Empty_Line := True;
   end Add_Line_Break;

   --  ------------------------------
   --  Add a paragraph (
).  Close the previous paragraph if any.
   --  The paragraph must be closed at the next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_Paragraph (Document : in out Text_Renderer) is
   begin
      Document.Close_Paragraph;
      Document.Need_Paragraph := True;
      Document.Add_Line_Break;
   end Add_Paragraph;

   --  ------------------------------
   --  Add a blockquote (
).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   overriding
   procedure Add_Blockquote (Document : in out Text_Renderer;
                             Level    : in Natural) is
   begin
      Document.Close_Paragraph;
      for I in 1 .. Level loop
         Document.Writer.Write ("  ");
      end loop;
   end Add_Blockquote;

   --  ------------------------------
   --  Add a list item (
).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_List_Item (Document : in out Text_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
      pragma Unreferenced (Level, Ordered);
   begin
      if not Document.Empty_Line then
         Document.Add_Line_Break;
      end if;
      Document.Need_Paragraph := False;
      Document.Open_Paragraph;
   end Add_List_Item;

   procedure Close_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Has_Paragraph then
         Document.Add_Line_Break;
      end if;
      Document.Has_Paragraph := False;
   end Close_Paragraph;

   procedure Open_Paragraph (Document : in out Text_Renderer) is
   begin
      if Document.Need_Paragraph then
         Document.Has_Paragraph  := True;
         Document.Need_Paragraph := False;
      end if;
   end Open_Paragraph;

   --  ------------------------------
   --  Add an horizontal rule (
).
   --  ------------------------------
   overriding
   procedure Add_Horizontal_Rule (Document : in out Text_Renderer) is
   begin
      Document.Close_Paragraph;
   end Add_Horizontal_Rule;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Document : in out Text_Renderer;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
      pragma Unreferenced (Language);
   begin
      Document.Open_Paragraph;
      if Length (Title) > 0 then
         Document.Writer.Write (Title);
      end if;
      Document.Writer.Write (Link);
      Document.Writer.Write (Name);
      Document.Empty_Line := False;
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Document    : in out Text_Renderer;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
      pragma Unreferenced (Position);
   begin
      Document.Open_Paragraph;
      if Length (Alt) > 0 then
         Document.Writer.Write (Alt);
      end if;
      if Length (Description) > 0 then
         Document.Writer.Write (Description);
      end if;
      Document.Writer.Write (Link);
      Document.Empty_Line := False;
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Document : in out Text_Renderer;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is
      pragma Unreferenced (Link, Language);
   begin
      Document.Open_Paragraph;
      Document.Writer.Write (Quote);
      Document.Empty_Line := False;
   end Add_Quote;

   --  ------------------------------
   --  Add a text block with the given format.
   --  ------------------------------
   overriding
   procedure Add_Text (Document : in out Text_Renderer;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Wiki.Documents.Format_Map) is
      pragma Unreferenced (Format);
   begin
      Document.Writer.Write (Text);
      Document.Empty_Line := False;
   end Add_Text;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   procedure Add_Preformatted (Document : in out Text_Renderer;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is
      pragma Unreferenced (Format);
   begin
      Document.Close_Paragraph;
      Document.Writer.Write (Text);
      Document.Empty_Line := False;
   end Add_Preformatted;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Text_Renderer) is
   begin
      Document.Close_Paragraph;
   end Finish;

end Wiki.Render.Text;

Implement the Wiki.Render.Text package and operations to render the text document


-- RUN: %llvmgcc -c %s -o /dev/null
procedure Array_Ref is
   type A is array (Natural range <>, Natural range <>) of Boolean;
   type A_Access is access A;
   function Get (X : A_Access) return Boolean is
   begin
      return X (0, 0);
   end;
begin
   null;
end;

Test handling of ARRAY_REF when the component type is of unknown size.

git-svn-id: 0ff597fd157e6f4fc38580e8d64ab130330d2411@35176 91177308-0d34-0410-b5e6-96231b3b80d8


-----------------------------------------------------------------------
--  escape -- Text Transformations
--  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 Util.Strings.Transforms;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with Ada.Command_Line;

procedure Escape is

   use Ada.Strings.Unbounded;

   Count : constant Natural := Ada.Command_Line.Argument_Count;
begin
   if Count = 0 then
      Ada.Text_IO.Put_Line ("Usage: escape string...");
      return;
   end if;
   for I in 1 .. Count loop
      declare
         S : constant String := Ada.Command_Line.Argument (I);
      begin
         Ada.Text_IO.Put_Line ("Escape javascript : "
                               & Util.Strings.Transforms.Escape_Javascript (S));
         Ada.Text_IO.Put_Line ("Escape XML        : "
                               & Util.Strings.Transforms.Escape_Xml (S));
      end;
   end loop;
end Escape;

Add simple example for text transformations


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

with ASF.Contexts.Faces;
with ASF.Requests;
package body ASF.Beans.Requests is

   Bean : aliased Request_Bean;

   --  ------------------------------
   --  Get from the request object the value identified by the given name.
   --  Returns Null_Object if the request does not define such name.
   --  ------------------------------
   overriding
   function Get_Value (Bean : in Request_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Bean);
      use type ASF.Contexts.Faces.Faces_Context_Access;

      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      if Ctx = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      declare
         Req    : constant ASF.Requests.Request_Access := Ctx.Get_Request;
      begin
         return Req.Get_Attribute (Name);
      end;
   end Get_Value;

   --  ------------------------------
   --  Return the Request_Bean instance.
   --  ------------------------------
   function Instance return Util.Beans.Objects.Object is
   begin
      return Util.Beans.Objects.To_Object (Bean'Access, Util.Beans.Objects.STATIC);
   end Instance;

end ASF.Beans.Requests;

Implement the implicit object 'requestScope'


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

package body MAT.Events.Targets is

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in MAT.Types.Uint16;
                     Frame  : in MAT.Events.Frame_Info) is
   begin
      Target.Events.Insert (Event, Frame);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_EVent_Counter;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event  : in MAT.Types.Uint16;
                        Frame  : in MAT.Events.Frame_Info) is
      begin
         null;
      end Insert;

   end Event_Collector;

end MAT.Events.Targets;

Implement the Insert and Get_Event_Counter operations


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

   use Ada.Text_IO;
   use Ada.Strings.Unbounded;

   --  ------------------------------
   --  Execute the GET API operation and print the raw JSON result.
   --  ------------------------------
   procedure Execute_Operation (Command   : in Command_Type;
                                Operation : in String;
                                Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type);

      procedure Execute_One (Gateway : in out Druss.Gateways.Gateway_Type) is
         Box     : Bbox.API.Client_Type;
      begin
         Box.Set_Server (To_String (Gateway.Ip));
         Box.Login (To_String (Gateway.Passwd));
         Ada.Text_IO.Put_Line (Box.Get (Operation));
      end Execute_One;

   begin
      Druss.Gateways.Iterate (Context.Gateways, Execute_One'Access);
   end Execute_Operation;

   --  ------------------------------
   --  Execute a GET operation on the Bbox API and return the raw JSON result.
   --  ------------------------------
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      if Args.Get_Count = 0 then
         Druss.Commands.Driver.Usage (Args);
      end if;
      for I in 1 .. Args.Get_Count loop
         declare
            Operation : constant String := Args.Get_Argument (I);
         begin
            Execute_Operation (Command, Operation, Context);
         end;
      end loop;
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command, Context);
   begin
      Put_Line ("get: Execute a GET operation on the Bbox API and print the raw JSON result");
      Put_Line ("Usage: get <operation>");
      New_Line;
      Put_Line ("  The Bbox API operation is called and the raw JSON result is printed.");
      Put_Line ("  Examples:");
      Put_Line ("    get device         Get information about the Bbox");
      Put_Line ("    get hosts          Get the list of hosts detected by the Bbox");
      Put_Line ("    get wan/ip         Get information about the WAN connection");
   end Help;

end Druss.Commands.Get;

Implement the get command to retrieve a Bbox API content and print the JSON raw result


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                        A 4 G . T R E E _ R E C                           --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (c) 1995-2005, 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).                                                   --
--                                                                          --
------------------------------------------------------------------------------

--  This package defines the Tree_Rec type, which is used as an actual for
--  the instantiation of the GANT Table creating the type for the Context tree
--  table. This table stores information about trees (tree output files)
--  cerating the Ada environment processed by a given Context

with A4G.A_Types; use A4G.A_Types;

with Types;       use Types;

package A4G.Tree_Rec is

   --  See the A4G.Contt.TT package for the details of maintaining
   --  the tree tables

   ------------------------------
   -- Tree_Rec type definition --
   ------------------------------

   --  Similar to the Contexts' Unit tables and Source File tables,
   --  Tree tables are organised as Name tables (for the names of the
   --  tree files), and each entry in such a Name table has additional
   --  fields for information related to tree files handling in ASIS.

   type Tree_Record is record

      --------------------------------
      -- Fields for Tree Name Table --
      --------------------------------

      Tree_Name_Chars_Index      : Int;
      --  Starting locations of characters in the Name_Chars table minus
      --  one (i.e. pointer to character just before first character). The
      --  reason for the bias of one is that indexes in Name_Buffer are
      --  one's origin, so this avoids unnecessary adds and subtracts of 1.

      Tree_Name_Len      : Short;
      --  Lengths of the names in characters

      Int_Info : Int;
      --  Int Value associated with this tree

      ---------------------
      -- Tree attributes --
      ---------------------

      Main_Unit : Unit_Id;
      --    The ASIS Compilation Unit, correspondig to the main unit in
      --    the tree

      Main_Top : Node_Id;
      --    The top node (having N_Compilation_Unit Node Kind) of Main_Unit
      --    DO WE REALLY NEED IT?

      Units : Elist_Id;
      --    The list of all the Units (or all the Units except Main_Unit?)
      --    which may be processed on the base of this tree, [each Unit
      --    is accompanied by its top node, which it has in the given tree
      --    ??? Not implemented for now!]

   end record;

end A4G.Tree_Rec;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  awa-mail-client -- Mail client interface
--  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.
-----------------------------------------------------------------------

--  The AWA.Mail.Clients package defines a mail client API used by the mail module.
--  It defines two interfaces that must be implemented.  This allows to have an implementation
--  based on an external application such as <tt>sendmail</tt> and other implementation that
--  use an SMTP connection.
package AWA.Mail.Clients is

   type Recipient_Type is (TO, CC, BCC);

   --  ------------------------------
   --  Mail Message
   --  ------------------------------
   --  The Mail_Message represents an abstract mail message that can be initialized
   --  before being sent.
   type Mail_Message is limited interface;
   type Mail_Message_Access is access all Mail_Message'Class;

   --  Set the <tt>From</tt> part of the message.
   procedure Set_From (Message : in out Mail_Message;
                       Name    : in String;
                       Address : in String) is abstract;

   --  Add a recipient for the message.
   procedure Add_Recipient (Message : in out Mail_Message;
                            Kind    : in Recipient_Type;
                            Name    : in String;
                            Address : in String) is abstract;

   --  Set the subject of the message.
   procedure Set_Subject (Message : in out Mail_Message;
                          Subject : in String) is abstract;

   --  Set the body of the message.
   procedure Set_Body (Message : in out Mail_Message;
                       Content : in String) is abstract;

   --  Send the email message.
   procedure Send (Message : in out Mail_Message) is abstract;

   --  ------------------------------
   --  Mail Manager
   --  ------------------------------
   --  The Mail_Manager is the entry point to create a new mail message
   --  and be able to send it.
   type Mail_Manager is limited interface;
   type Mail_Manager_Access is access all Mail_Manager'Class;

   --  Create a new mail message.
   function Create_Message (Manager : in Mail_Manager) return Mail_Message_Access is abstract;

end AWA.Mail.Clients;

Define a set of interface to send an email and have several possible implementations


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--   A S I S . D A T A _ D E C O M P O S I T I O N . E X T E N S I O N S    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2010, 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 Ada.Unchecked_Conversion;
with System;                          use System;

with Asis.Data_Decomposition.Vcheck;  use Asis.Data_Decomposition.Vcheck;
with Asis.Data_Decomposition.Set_Get; use Asis.Data_Decomposition.Set_Get;
with Asis.Errors;                     use Asis.Errors;
with Asis.Exceptions;                 use Asis.Exceptions;
with Asis.Set_Get;                    use Asis.Set_Get;

with A4G.DDA_Aux;                     use A4G.DDA_Aux;
with A4G.Vcheck;                      use A4G.Vcheck;

with Einfo;                           use Einfo;
with Namet;                           use Namet;
with Uintp;                           use Uintp;
with Urealp;                          use Urealp;

package body Asis.Data_Decomposition.Extensions  is

   Package_Name : constant String := "Asis.Data_Decomposition.Extensions.";

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

   procedure Write_Real_To_Buffer (U : Ureal);
   --  Puts nnn/ddd to Name_Buffer, where nnn and ddd are integer values of
   --  the normalized numerator and denominator of the given real value.
   --  This procedure is supposed to be used to output images of positive
   --  real values only, so it assumes, that nnn is always positive.

   procedure Add_Uint_To_Buffer (U : Uint);
   --  Add image of universal integer to Name_Buffer, updating Name_Len
   --  (This procedure is the simplified version of the local procedure
   --  Exp_Dbug.Add_Uint_To_Buffer - it always consider its argument
   --  being positive)

   ------------------------
   -- Add_Uint_To_Buffer --
   ------------------------

   procedure Add_Uint_To_Buffer (U : Uint) is
   begin
      UI_Image (U, Decimal);
      Add_Str_To_Name_Buffer (UI_Image_Buffer (1 .. UI_Image_Length));
   end Add_Uint_To_Buffer;

   -------------------------------
   -- Component_Name_Definition --
   -------------------------------

   function Component_Name_Definition
     (Component : Record_Component)
      return      Asis.Declaration
   is
      Result : Asis.Element;
   begin
      Check_Validity (Component, Package_Name & "Component_Name_Definition");

      if Is_Nil (Component) then
         Raise_ASIS_Inappropriate_Component
           (Diagnosis      => Package_Name & "Component_Name_Definition",
            Component_Kind => Rec);
      end if;

      Result := Component_Name (Component);

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

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

         end if;

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

   --------------------------
   -- Delta_Value (String) --
   --------------------------

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String
   is
      Arg_Node      : Node_Id;
      Res_Ureal     : Ureal;
   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Delta_Value (String)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (String)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Delta_Value (Arg_Node);

      Write_Real_To_Buffer (Res_Ureal);

      return Namet.Name_Buffer (1 .. Namet.Name_Len);

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Delta_Value (String)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Delta_Value (String)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Delta_Value;

   ----------------------------
   -- Delta_Value (Fraction) --
   ----------------------------

   function Delta_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                Fraction
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

      Result    : Fraction;

   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Delta_Value (Fraction)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Delta_Value (Arg_Node);

      Result.Num   := UI_To_Aint (Norm_Num (Res_Ureal));
      Result.Denum := UI_To_Aint (Norm_Den (Res_Ureal));

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Delta_Value (Fraction)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Invalid_Data =>
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Delta_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype),
            Status     => Data_Error);
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Delta_Value (Fraction)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Delta_Value;

   ------------------
   -- Digits_Value --
   ------------------

   function Digits_Value
     (Floating_Point_Subtype : Asis.Element)
      return                   ASIS_Natural
   is
      Arg_Node      : Node_Id;
   begin
      Check_Validity (Floating_Point_Subtype, Package_Name & "Digits_Value");

      Arg_Node := R_Node (Floating_Point_Subtype);

      if not (Int_Kind (Floating_Point_Subtype) = A_Defining_Identifier
            and then
             (Is_Decimal_Fixed_Point_Type (Arg_Node) or else
              Is_Floating_Point_Type (Arg_Node)))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Digits_Value",
            Wrong_Kind => Int_Kind (Floating_Point_Subtype));
      end if;

      return ASIS_Natural (UI_To_Int (Einfo.Digits_Value (Arg_Node)));

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Digits_Value",
               Argument   => Floating_Point_Subtype);
         end if;

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

   --------------------------
   --  Portable_Data_Value --
   --------------------------

   function Portable_Data_Value
     (Value : Constrained_Subtype)
      return  Portable_Data
   is

      Local_Value : aliased constant Constrained_Subtype := Value;
      for Local_Value'Alignment use Standard'Maximum_Alignment;
      --  We force the maximum alignment for Local_Value to make it
      --  compatible with maximum alignment set for Portable_Data
      --  in the spec of Asis.Data_Decomposition

      subtype Result_Portable_Data is
         Portable_Data (1 .. (Constrained_Subtype'Object_Size + 7) / 8);

      type Result_Portable_Data_Access is access Result_Portable_Data;

      function To_Result_Portable_Data_Access is new
         Ada.Unchecked_Conversion (Address, Result_Portable_Data_Access);

      Result : constant Result_Portable_Data_Access :=
         To_Result_Portable_Data_Access (Local_Value'Address);

   begin

      return Result.all;
   exception
      when ASIS_Failed =>

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

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

   -----------------
   -- Scale_Value --
   -----------------

   function Scale_Value
     (Desimal_Fixed_Point_Subtype : Asis.Element)
      return                        ASIS_Natural
   is
      Arg_Node      : Node_Id;

   begin
      Check_Validity
        (Desimal_Fixed_Point_Subtype, Package_Name & "Scale_Value");

      Arg_Node := R_Node (Desimal_Fixed_Point_Subtype);

      if not (Int_Kind (Desimal_Fixed_Point_Subtype) = A_Defining_Identifier
            and then
              Is_Decimal_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Scale_Value",
            Wrong_Kind => Int_Kind (Desimal_Fixed_Point_Subtype));
      end if;

      return ASIS_Natural (UI_To_Int (Einfo.Scale_Value (Arg_Node)));

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Scale_Value",
               Argument   => Desimal_Fixed_Point_Subtype);
         end if;

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

   --------------------------
   -- Small_Value (String) --
   --------------------------

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                String
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Small_Value (String)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Small_Value (String)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Small_Value (Arg_Node);

      Write_Real_To_Buffer (Res_Ureal);

      return Namet.Name_Buffer (1 .. Namet.Name_Len);

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Small_Value (String)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Small_Value (String)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Small_Value;

   ----------------------------
   -- Small_Value (Fraction) --
   ----------------------------

   function Small_Value
     (Fixed_Point_Subtype : Asis.Element)
      return                Fraction
   is
      Arg_Node  : Node_Id;
      Res_Ureal : Ureal;

      Result    : Fraction;
   begin
      Check_Validity
        (Fixed_Point_Subtype, Package_Name & "Small_Value (Fraction)");

      Arg_Node := R_Node (Fixed_Point_Subtype);

      if not (Int_Kind (Fixed_Point_Subtype) = A_Defining_Identifier and then
              Is_Fixed_Point_Type (Arg_Node))
      then
         Raise_ASIS_Inappropriate_Element
           (Package_Name & "Small_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype));
      end if;

      Res_Ureal := Einfo.Small_Value (Arg_Node);

      Result.Num   := UI_To_Aint (Norm_Num (Res_Ureal));
      Result.Denum := UI_To_Aint (Norm_Den (Res_Ureal));

      return Result;

   exception
      when ASIS_Inappropriate_Element =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information
              (Outer_Call => Package_Name & "Small_Value (Fraction)",
               Argument   => Fixed_Point_Subtype);
         end if;

         raise;

      when Invalid_Data =>
         Raise_ASIS_Inappropriate_Element
           (Diagnosis  => Package_Name & "Small_Value (Fraction)",
            Wrong_Kind => Int_Kind (Fixed_Point_Subtype),
            Status     => Data_Error);
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name  => Package_Name & "Small_Value (Fraction)",
           Ex          => Ex,
           Arg_Element => Fixed_Point_Subtype);
   end Small_Value;

   --------------------------
   -- Write_Real_To_Buffer --
   --------------------------

   procedure Write_Real_To_Buffer (U : Ureal) is
   begin
      Namet.Name_Len := 0;

      Add_Uint_To_Buffer (Norm_Num (U));
      Add_Str_To_Name_Buffer ("/");
      Add_Uint_To_Buffer (Norm_Den (U));
   end Write_Real_To_Buffer;

end Asis.Data_Decomposition.Extensions;

Add the ASIS file $i

Add the ASIS file $i


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

with Asis.Errors;  use Asis.Errors;

with A4G.A_Types;  use A4G.A_Types;
with A4G.A_Osint;  use A4G.A_Osint;
with A4G.A_Output; use A4G.A_Output;
with A4G.A_Debug;  use A4G.A_Debug;
with A4G.Vcheck;   use A4G.Vcheck;

with GNAT.OS_Lib;  use GNAT.OS_Lib;

package body A4G.A_Opt is

   -------------------------------------
   -- Process_Finalization_Parameters --
   -------------------------------------

   procedure Process_Finalization_Parameters (Parameters : String) is
      Final_Parameters : Argument_List_Access;

      procedure Process_One_Parameter (Param : String);
      --  incapsulates processing of a separate parameter

      ---------------------------
      -- Process_One_Parameter --
      ---------------------------

      procedure Process_One_Parameter (Param : String) is
         Parameter : constant String (1 .. Param'Length) := Param;
      begin
         ASIS_Warning
            (Message => "Asis.Implementation.Finalize: "
                      & "unknown parameter - "
                      & Parameter,
             Error   => Parameter_Error);
      end Process_One_Parameter;

   begin  -- Process_Finalization_Parameters
      Final_Parameters := Parameter_String_To_List (Parameters);

      for I in Final_Parameters'Range loop
         Process_One_Parameter (Final_Parameters (I).all);
      end loop;

      Free_Argument_List (Final_Parameters);
   end Process_Finalization_Parameters;

   ---------------------------------------
   -- Process_Initialization_Parameters --
   ---------------------------------------

   procedure Process_Initialization_Parameters (Parameters : String) is
      Init_Parameters : Argument_List_Access;

      procedure Process_One_Parameter (Param : String);
      --  incapsulates processing of a separate parameter

      ---------------------------
      -- Process_One_Parameter --
      ---------------------------

      procedure Process_One_Parameter (Param : String) is
         Parameter : constant String (1 .. Param'Length) := Param;
         Unknown_Parameter : Boolean := False;
         subtype Dig is Character range '1' .. '9';
         subtype Let is Character range 'a' .. 'z';

         procedure Process_Parameter;
         procedure Process_Option;
         --  Process_Option works if Param starts from '-', and
         --  Process_Parameter works otherwise

         procedure Process_Parameter is
         begin
            --  no parameter is currently available as an ASIS initialization
            --  parameter
            Raise_ASIS_Failed
               (Diagnosis    => "Asis.Implementation.Initialize: "
                              & "unknown parameter - "
                              & Parameter,
                Stat         => Parameter_Error,
                Internal_Bug => False);
         end Process_Parameter;

         procedure Process_Option is
         begin

            case Parameter (2) is

               when 'a' =>

                  if Parameter = "-asis05"
                    or else
                     Parameter = "-asis12"
                    or else
                     Parameter = "-asis95"
                  then
                     --  We have to accept these parameters because of
                     --  compatibility reasons
                     null;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'd' =>

                  if   Parameter'Length = 3
                     and then
                      (Parameter (3) in Dig or else
                       Parameter (3) in Let)
                  then
                     Set_Debug_Flag (Parameter (3));
                  elsif Parameter = "-dall" then
                     A4G.A_Debug.Set_On;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'k' =>

                  if Parameter = "-k" then
                     Keep_Going := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'n' =>

                  if Parameter = "-nbb" then
                     Generate_Bug_Box := False;
                     Keep_Going       := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 's' =>

                  if Parameter = "-sv" then
                     Strong_Version_Check := True;
                  else
                     Unknown_Parameter := True;
                  end if;

               when 'w' =>

                  if Parameter = "-ws" then
                     ASIS_Warning_Mode := Suppress;
                  elsif Parameter = "-we" then
                     ASIS_Warning_Mode := Treat_As_Error;
                  elsif Parameter = "-wv" then
                     Strong_Version_Check := False;
                  else
                     Unknown_Parameter := True;
                  end if;

               when others =>
                  Unknown_Parameter := True;
            end case;

            if Unknown_Parameter then
               Raise_ASIS_Failed
                  (Diagnosis    => "Asis.Implementation.Initialize: "
                                 & "unknown option - "
                                 & Parameter,
                   Stat         => Parameter_Error,
                   Internal_Bug => False);
            end if;

         end Process_Option;

      begin --  Process_One_Parameter
         if Parameter (1) = '-' then
            if Parameter'Length >= 2 then
               Process_Option;
            else
               Raise_ASIS_Failed
                  (Diagnosis => "Asis.Implementation.Initialize: "
                              & "Option is missing after ""-""",
                   Stat      => Parameter_Error,
                Internal_Bug => False);
            end if;
         else
            Process_Parameter;
         end if;
      end Process_One_Parameter;

   begin  -- Process_Initialization_Parameters
      Init_Parameters := Parameter_String_To_List (Parameters);

      for I in Init_Parameters'Range loop
         Process_One_Parameter (Init_Parameters (I).all);
      end loop;

      Free_Argument_List (Init_Parameters);
   end Process_Initialization_Parameters;

   -------------
   -- Set_Off --
   -------------

   procedure Set_Off is
   begin
      Is_Initialized       := False;
      ASIS_Warning_Mode    := Normal;
      Strong_Version_Check := True;
      Generate_Bug_Box     := True;
      Keep_Going           := False;
   end Set_Off;

end A4G.A_Opt;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  util-dates-rfc7231-- RFC7231 date format utilities
--  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 Util.Dates.RFC7231 is

   use Ada.Calendar;
   use Ada.Calendar.Formatting;

   Day_Names : constant array (Day_Name) of String (1 .. 3)
     := (Sunday => "Sun", Monday => "Mon", Tuesday => "Tue",
         Wednesday => "Wed", Thursday => "Thu", Friday => "Fri", Saturday => "Sat");

   Month_Names : constant array (Month_Number) of String (1 .. 3)
     := ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug",
         "Sep", "Oct", "Nov", "Dec");

   procedure Append_Digits (Into  : in out Util.Strings.Builders.Builder;
                            Value : in Natural);

   function Get_Day (Day : in String) return Day_Name;
   function Get_Month (Month : in String) return Month_Number;

   procedure Append_Digits (Into  : in out Util.Strings.Builders.Builder;
                            Value : in Natural) is
      use Util.Strings.Builders;
   begin
      Append (Into, Character'Val (Character'Pos ('0') + Value / 10));
      Append (Into, Character'Val (Character'Pos ('0') + Value mod 10));
   end Append_Digits;

   --  ------------------------------
   --  Append the date in RFC7231/RFC2616 format in the string builder.
   --  The date separator can be changed to '-' to generate a cookie expires date.
   --  ------------------------------
   procedure Append_Date (Into           : in out Util.Strings.Builders.Builder;
                          Date           : in Ada.Calendar.Time;
                          Date_Separator : in Character := ' ') is
      use Util.Strings.Builders;

      Wday  : constant Day_Name := Day_Of_Week (Date);
      Year  : Year_Number;
      Month : Month_Number;
      Day   : Day_Number;
      Hour  : Hour_Number;
      Min   : Minute_Number;
      Sec   : Second_Number;
      Ssec  : Second_Duration;
   begin
      Split (Date, Year, Month, Day, Hour, Min, Sec, Ssec);
      Append (Into, Day_Names (Wday));
      Append (Into, ", ");
      Append_Digits (Into, Integer (Day));
      Append (Into, Date_Separator);
      Append (Into, Month_Names (Month));
      Append (Into, Date_Separator);
      Append_Digits (Into, Integer (Year / 100));
      Append_Digits (Into, Integer (Year mod 100));
      Append (Into, ' ');
      Append_Digits (Into, Integer (Hour));
      Append (Into, ':');
      Append_Digits (Into, Integer (Min));
      Append (Into, ':');
      Append_Digits (Into, Integer (Sec));
      Append (Into, " GMT");
   end Append_Date;

   function Get_Month (Month : in String) return Month_Number is
   begin
      for I in Month_Names'Range loop
         if Month_Names (I) = Month then
            return I;
         end if;
      end loop;
      raise Constraint_Error with "Invalid month";
   end Get_Month;

   function Get_Day (Day : in String) return Day_Name is
   begin
      for I in Day_Names'Range loop
         if Day_Names (I) = Day then
            return I;
         end if;
      end loop;
      raise Constraint_Error with "Invalid day name";
   end Get_Day;

   --  ------------------------------
   --  Parses a HTTP date that follows the RFC7231 or RFC2616 format.
   --  Raises Constraint_Error if the date format is not recognized.
   --  ------------------------------
   function Value (Date : in String) return Ada.Calendar.Time is
      Year  : Year_Number;
      Month : Month_Number;
      Day   : Day_Number;
      Hour  : Hour_Number;
      Min   : Minute_Number;
      Sec   : Second_Number;
      Wday  : Day_Name;
      Leap_Second : Boolean := False;

      pragma Unreferenced (Wday);
   begin
      if Date'Length < 10 then
         raise Constraint_Error with "Invalid date format";
      end if;
      if Date (Date'First + 3) = ',' then
         --  This is a fixed format, check for date separators.
         if Date (Date'First + 7) /= ' '
           or else Date (Date'First + 11) /= ' '
           or else Date (Date'First + 16) /= ' '
           or else Date (Date'First + 19) /= ':'
           or else Date (Date'First + 22) /= ':'
           or else Date (Date'First + 25 .. Date'Last) /= " GMT"
         then
            raise Constraint_Error with "Invalid date format";
         end if;
         Wday := Get_Day (Date (Date'First .. Date'First + 2));
         Day := Day_Number'Value (Date (Date'First + 5 .. Date'First + 6));
         Month := Get_Month (Date (Date'First + 8 .. Date'First + 10));
         Year := Year_Number'Value (Date (Date'First + 12 .. Date'First + 15));
         Hour := Hour_Number'Value (Date (Date'First + 17 .. Date'First + 18));
         Min := Minute_Number'Value (Date (Date'First + 20 .. Date'First + 21));
         if Date (Date'First + 23 .. Date'First + 24) = "60" then
            Leap_Second := True;
            Sec := 59;
         else
            Sec := Second_Number'Value (Date (Date'First + 23 .. Date'First + 24));
         end if;
      else
         raise Constraint_Error with "Invalid date format (deprecated formats not supported)";
      end if;
      return Ada.Calendar.Formatting.Time_Of (Year        => Year,
                                              Month       => Month,
                                              Day         => Day,
                                              Hour        => Hour,
                                              Minute      => Min,
                                              Second      => Sec,
                                              Sub_Second  => 0.0,
                                              Leap_Second => Leap_Second);
   end Value;

   --  ------------------------------
   --  Return the RFC7231/RFC2616 date format.
   --  ------------------------------
   function Image (Date : in Ada.Calendar.Time) return String is
      Result : Util.Strings.Builders.Builder (Len => 40);
   begin
      Append_Date (Into => Result,
                   Date => Date);
      return Util.Strings.Builders.To_Array (Result);
   end Image;

end Util.Dates.RFC7231;

Implement the Value, Image and Append_Date operations


-----------------------------------------------------------------------
--  decompress - Decompress example based on the 02_decompress.c example
--  The MIT License (MIT)
--
--  Copyright (c) 2015 Stephane Carrez
--
--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:
--
--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.
--
--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.
-----------------------------------------------------------------------
with Ada.Command_Line;
with Ada.Text_IO;
with Ada.Streams;
with Ada.Streams.Stream_IO;

with Interfaces.C;

with Lzma;
with Lzma.Base;
with Lzma.Container;
procedure Decompress is

   use type Interfaces.C.size_t;
   use type Lzma.Base.lzma_ret;

   procedure Init_Decoder;
   procedure Decompress (Source : in String;
                         Dest   : in String);

   BUFSIZE : constant Ada.Streams.Stream_Element_Offset := 4096;

   Stream  : aliased Lzma.Base.lzma_stream := Lzma.Base.LZMA_STREAM_INIT;

   procedure Init_Decoder is
      Result : Lzma.Base.lzma_ret;
   begin
      Result := Lzma.Container.lzma_stream_decoder (Stream'Unchecked_Access,
                                                    Long_Long_Integer'Last,
                                                    Lzma.Container.LZMA_CONCATENATED);
      if Result /= Lzma.Base.LZMA_OK then
         Ada.Text_IO.Put_Line ("Error initializing the decoder: "
                                 & Lzma.Base.lzma_ret'Image (Result));
      end if;
   end Init_Decoder;

   --  ------------------------------
   --  Open the source file for reading, decompress that file and write the decompressed
   --  output in the destination file.
   --  ------------------------------
   procedure Decompress (Source : in String;
                         Dest   : in String) is

      Infile     : Ada.Streams.Stream_IO.File_Type;
      Outfile    : Ada.Streams.Stream_IO.File_Type;
      Sbuf       : aliased Ada.Streams.Stream_Element_Array (1 .. BUFSIZE);
      Dbuf       : aliased Ada.Streams.Stream_Element_Array (1 .. BUFSIZE);
      Action     : Lzma.Base.lzma_action := Lzma.Base.LZMA_RUN;
      Last       : Ada.Streams.Stream_Element_Offset;
      Result     : Lzma.Base.lzma_ret;
   begin
      Ada.Streams.Stream_IO.Open (Infile, Ada.Streams.Stream_IO.In_File, Source);
      Ada.Streams.Stream_IO.Create (Outfile, Ada.Streams.Stream_IO.Out_File, Dest);

      Stream.next_out  := Dbuf (Dbuf'First)'Unchecked_Access;
      Stream.avail_out := Dbuf'Length;
      loop
         --  Read a block of data from the source file.
         if Stream.avail_in = 0 and not Ada.Streams.Stream_IO.End_Of_File (Infile) then
            Stream.next_in := Sbuf (Sbuf'First)'Unchecked_Access;
            Ada.Streams.Stream_IO.Read (Infile, Sbuf, Last);
            Stream.avail_in := Interfaces.C.size_t (Last);
            if Ada.Streams.Stream_IO.End_Of_File (Infile) then
               Action := Lzma.Base.LZMA_FINISH;
            end if;
         end if;
         Result := Lzma.Base.lzma_code (Stream'Unchecked_Access, Action);

         --  Write the output data when the buffer is full or we reached the end of stream.
         if Stream.avail_out = 0 or Result = Lzma.Base.LZMA_STREAM_END then
            Last := Ada.Streams.Stream_Element_Offset (Dbuf'Length - Stream.avail_out);
            Ada.Streams.Stream_IO.Write (Outfile, Item => Dbuf (Dbuf'First .. Last));
            Stream.next_out := Dbuf (Dbuf'First)'Unchecked_Access;
            Stream.avail_out := Dbuf'Length;
         end if;
         exit when Result /= Lzma.Base.LZMA_OK;
      end loop;
      Ada.Streams.Stream_IO.Close (Infile);
      Ada.Streams.Stream_IO.Close (Outfile);
      if Result /= Lzma.Base.LZMA_STREAM_END then
         Ada.Text_IO.Put_Line ("Error while decompressing the input stream: "
                              & Lzma.Base.lzma_ret'Image (Result));
      end if;
   end Decompress;

begin
   if Ada.Command_Line.Argument_Count /= 2 then
      Ada.Text_IO.Put_Line ("Usage: decompress input output.xz");
      return;
   end if;
   Init_Decoder;
   Decompress (Ada.Command_Line.Argument (1), Ada.Command_Line.Argument (2));
   Lzma.Base.lzma_end (Stream'Unchecked_Access);
end Decompress;

Decompress example based on the 02_decompress.c example of liblzma