-----------------------------------------------------------------------
--  components-widgets-tabs -- Tab views and tabs
--  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 ASF.Components.Base;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Tabs is

   --  ------------------------------
   --  Render the tab start.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UITab;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", UI.Get_Client_Id);
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Render the tab close.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UITab;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.End_Element ("div");
      end if;
   end Encode_End;

   --  ------------------------------
   --  Render the tab list and prepare to render the tab contents.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UITabView;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

      procedure Render_Tab (T : in Components.Base.UIComponent_Access);

      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;

      procedure Render_Tab (T : in Components.Base.UIComponent_Access) is
         Id : constant Unbounded_String := T.Get_Client_Id;
      begin
         if T.all in UITab'Class then
            Writer.Start_Element ("li");
            Writer.Start_Element ("a");
            Writer.Write_Attribute ("href", "#" & To_String (Id));
            Writer.Write_Text (T.Get_Attribute ("title", Context));
            Writer.End_Element ("a");
            Writer.End_Element ("li");
         end if;
      end Render_Tab;

      procedure Render_Tabs is
        new ASF.Components.Base.Iterate (Process => Render_Tab);

   begin
      if UI.Is_Rendered (Context) then
         declare
            Id : constant Unbounded_String := UI.Get_Client_Id;
         begin
            Writer.Start_Element ("div");
            Writer.Write_Attribute ("id", Id);
            Writer.Start_Element ("ul");
            Render_Tabs (UI);
            Writer.End_Element ("ul");
            Writer.Queue_Script ("$(""#");
            Writer.Queue_Script (Id);
            Writer.Queue_Script (""").tabs({");
            Writer.Queue_Script ("});");
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Render the tab view close.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UITabView;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.End_Element ("div");
      end if;
   end Encode_End;

end ASF.Components.Widgets.Tabs;

Implement the new <w:tab> and <w:tabView> components


------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                             A S I S . I D 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.Characters.Handling; use Ada.Characters.Handling;

with A4G.Vcheck; use A4G.Vcheck;

package body Asis.Ids is
------------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Hash (The_Id : Id) return Asis.ASIS_Integer is
   begin
      pragma Unreferenced (The_Id);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Hash");
      return 0;
   end Hash;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function "<" (Left  : Id;
                 Right : Id) return Boolean is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.""<""");
      return True;
   end "<";
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function ">" (Left  : Id;
                 Right : Id) return Boolean is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids."">""");
      return False;
   end ">";
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Is_Nil (Right : Id) return Boolean is
   begin
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Is_Nil");
      return True;
   end Is_Nil;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Is_Equal
     (Left  : Id;
      Right : Id)
      return Boolean
   is
   begin
      pragma Unreferenced (Left);
      pragma Unreferenced (Right);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Is_Equal");
      return True;
   end Is_Equal;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Create_Id (Element : Asis.Element) return Id is
   begin
      pragma Unreferenced (Element);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Create_Id");
      return Nil_Id;
   end Create_Id;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Create_Element
     (The_Id      : Id;
      The_Context : Asis.Context)
      return Asis.Element
   is
   begin
      pragma Unreferenced (The_Id);
      pragma Unreferenced (The_Context);
      Raise_ASIS_Failed (Diagnosis => "Asis.Ids.Create_Element");
      return Nil_Element;
   end Create_Element;
-----------------------------------------------------------------------------
--  NOT IMPLEMENTED

   function Debug_Image (The_Id : Id) return Wide_String is
   begin

      if Is_Nil (The_Id) then
         return Nil_Asis_Wide_String;
      else
         return To_Wide_String (The_Id.all);
      end if;

   end Debug_Image;
-----------------------------------------------------------------------------
end Asis.Ids;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  widgets-factory -- Factory for widget Components
--  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 ASF.Views.Nodes;
with ASF.Components.Base;
with ASF.Components.Widgets.Inputs;

package body ASF.Components.Widgets.Factory is

   use ASF.Components.Base;

   function Create_Input return UIComponent_Access;

   --  -------------------------
   --  ------------------------------
   --  Create a UIFile component
   --  ------------------------------
   function Create_Input return UIComponent_Access is
   begin
      return new ASF.Components.Widgets.Inputs.UIInput;
   end Create_Input;

   use ASF.Views.Nodes;

   URI            : aliased constant String := "http://code.google.com/p/ada-asf/widget";
   INPUT_TEXT_TAG : aliased constant String := "inputText";

   Widget_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => INPUT_TEXT_TAG'Access,
               Component => Create_Input'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Widget_Bindings'Access);

   --  ------------------------------
   --  Get the widget component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Widgets.Factory;

Implement the widget component factory

Implement the widget component factory


------------------------------------------------------------------------------
--                                                                          --
--                   ASIS-for-GNAT INTERFACE COMPONENTS                     --
--                                                                          --
--                             A S I S . I D S                              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 1995-2008, Free Software Foundation, Inc.       --
--                                                                          --
-- This   specification  is  derived   from  the  Ada   Semantic  Interface --
-- Specification Standard (ISO/IEC 15291) for use with GNAT.  The copyright --
-- notice above, and the license provisions that follow apply solely to the --
--  contents of the part following the private keyword.                     --
--                                                                          --
-- 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).                                                   --
--                                                                          --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
--  21 package Asis.Ids
------------------------------------------------------------------------------
------------------------------------------------------------------------------
package Asis.Ids is
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  Asis.Ids provides support for permanent unique Element "Identifiers" (Ids).
--  An Id is an efficient way for a tool to reference an ASIS element.  The Id
--  is permanent from session to session provided that the Ada compilation
--  environment is unchanged.
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  This package encapsulates a set of operations and queries that implement
--  the ASIS Id abstraction.  An Id is a way of identifying a particular
--  Element, from a particular Compilation_Unit, from a particular Context.
--  Ids can be written to files.  Ids can be read from files and converted into
--  an Element value with the use of a suitable open Context.
--
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--  21.1  type Id
------------------------------------------------------------------------------
--  The Ada element Id abstraction (a private type).
--
--  The Id type is a distinct abstract type representing permanent "names"
--  that correspond to specific Element values.
--
--  These names can be written to files, retrieved at a later time, and
--  converted to Element values.
------------------------------------------------------------------------------
--  ASIS Ids are a means of identifying particular Element values obtained from
--  a particular physical compilation unit.  Ids are "relative names".  Each Id
--  value is valid (is usable, makes sense, can be interpreted) only in the
--  context of an appropriate open ASIS Context.
--
--  Id shall be an undiscriminated private type, or, shall be derived from an
--  undiscriminated private type.  It shall be declared as a new type or as a
--  subtype of an existing type.
------------------------------------------------------------------------------

   type Id is private;
   Nil_Id : constant Id;

   function "=" (Left : Id; Right : Id) return Boolean is abstract;

------------------------------------------------------------------------------
--  21.2  function Hash
------------------------------------------------------------------------------

   function Hash (The_Id : Id) return Asis.ASIS_Integer;

------------------------------------------------------------------------------
--  21.3  function "<"
------------------------------------------------------------------------------

   function "<" (Left : Id; Right : Id) return Boolean;

------------------------------------------------------------------------------
--  21.4  function ">"
------------------------------------------------------------------------------

   function ">" (Left : Id; Right : Id) return Boolean;

------------------------------------------------------------------------------
--  21.5  function Is_Nil
------------------------------------------------------------------------------

   function Is_Nil (Right : Id) return Boolean;

------------------------------------------------------------------------------
--  Right   - Specifies the Id to check
--
--  Returns True if the Id is the Nil_Id.
--
------------------------------------------------------------------------------
--  21.6  function Is_Equal
------------------------------------------------------------------------------

   function Is_Equal (Left : Id; Right : Id) return Boolean;

------------------------------------------------------------------------------
--  Left    - Specifies the left Id to compare
--  Right   - Specifies the right Id to compare
--
--  Returns True if Left and Right represent the same physical Id, from the
--  same physical compilation unit.  The two Ids convert
--  to Is_Identical Elements when converted with the same open ASIS Context.
--
------------------------------------------------------------------------------
--  21.7  function Create_Id
------------------------------------------------------------------------------

   function Create_Id (Element : Asis.Element) return Id;

------------------------------------------------------------------------------
--  Element - Specifies any Element value whose Id is desired
--
--  Returns a unique Id value corresponding to this Element, from the
--  corresponding Enclosing_Compilation_Unit and the corresponding
--  Enclosing_Context.  The Id value will not be equal ("=") to the Id value
--  for any other Element value unless the two Elements are Is_Identical.
--
--  Nil_Id is returned for a Nil_Element.
--
--  All Element_Kinds are appropriate.
--
------------------------------------------------------------------------------
--  21.8  function Create_Element
------------------------------------------------------------------------------

   function Create_Element
     (The_Id      : Id;
      The_Context : Asis.Context)
      return Asis.Element;

------------------------------------------------------------------------------
--  The_Id      - Specifies the Id to be converted to an Element
--  The_Context - Specifies the Context containing the Element with this Id
--
--  Returns the Element value corresponding to The_Id.  The_Id shall
--  correspond to an Element available from a Compilation_Unit contained by
--  (referencible through) The_Context.
--
--  Raises ASIS_Inappropriate_Element if the Element value is not available
--  though The_Context.  The Status is Value_Error and the Diagnosis
--  string will attempt to indicate the reason for the failure. (e.g., "Unit is
--  inconsistent", "No such unit", "Element is inconsistent (Unit
--  inconsistent)", etc.)
--

------------------------------------------------------------------------------
--  21.9  function Debug_Image
------------------------------------------------------------------------------

   function Debug_Image (The_Id : Id) return Wide_String;

------------------------------------------------------------------------------
--  The_Id  - Specifies an Id to convert
--
--  Returns a string value containing implementation-defined debug
--  information associated with the Id.
--
--  The return value uses Asis.Text.Delimiter_Image to separate the lines
--  of multi-line results.  The return value does not end with
--  Asis.Text.Delimiter_Image.
--
--  These values are intended for two purposes.  They are suitable for
--  inclusion in problem reports sent to the ASIS implementor.  They can
--  be presumed to contain information useful when debugging the
--  implementation itself. They are also suitable for use by the ASIS
--  application when printing simple application debugging messages during
--  application development.  They are intended to be, to some worthwhile
--  degree, intelligible to the user.
--
------------------------------------------------------------------------------
private

   --  The content of this private part is specific for the ASIS
   --  implementation for GNAT

   type Id is access String;
   Nil_Id : constant Id := null;

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

end Asis.Ids;

Add the ASIS file $i

Add the ASIS file $i


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

--  == Introduction ==
--  The `Listeners` package implements a simple observer/listener design pattern.
--  A subscriber registers to a list.  When a change is made on an object, the
--  application can notify the subscribers which are then called with the object.
--
--  == Creating the listener list ==
--  The listeners list contains a list of listener interfaces.
--
--    L : Util.Listeners.List;
--
--  The list is heterogeneous meaning that several kinds of listeners could
--  be registered.
--
--  == Creating the observers ==
--  First the `Observers` package must be instantiated with the type being
--  observed.  In the example below, we will observe a string:
--
--    package String_Observers is new Util.Listeners.Observers (String);
--
--  == Implementing the observer ==
--  Now we must implement the string observer:
--
--    type String_Observer is new String_Observer.Observer with null record;
--    procedure Update (List : in String_Observer; Item : in String);
--
--  == Registering the observer ==
--  An instance of the string observer must now be registered in the list.
--
--    O : aliased String_Observer;
--    L.Append (O'Access);
--
--  == Publishing ==
--  Notifying the listeners is done by invoking the `Notify` operation
--  provided by the `String_Observers` package:
--
--    String_Observer.Notify (L, "Hello");
--
package Util.Listeners is

   --  The listener root interface.
   type Listener is limited interface;
   type Listener_Access is access all Listener'Class;

   --  The multi-task safe list of listeners.
   package Listener_Arrays is new Util.Concurrent.Arrays (Listener_Access);

   --  ------------------------------
   --  List of listeners
   --  ------------------------------
   --  The `List` type is a list of listeners that have been registered and must be
   --  called when a notification is sent.  The list uses the concurrent arrays thus
   --  allowing tasks to add or remove listeners while dispatching is also running.
   type List is new Listener_Arrays.Vector with null record;

   procedure Add_Listener (Into : in out Listener_Arrays.Vector;
                           Item : in Listener_Access) renames Listener_Arrays.Append;

   procedure Remove_Listener (Into : in out Listener_Arrays.Vector;
                              Item : in Listener_Access) renames Listener_Arrays.Remove;

end Util.Listeners;

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

--  == Introduction ==
--  The `Listeners` package implements a simple observer/listener design pattern.
--  A subscriber registers to a list.  When a change is made on an object, the
--  application can notify the subscribers which are then called with the object.
--
--  == Creating the listener list ==
--  The listeners list contains a list of listener interfaces.
--
--    L : Util.Listeners.List;
--
--  The list is heterogeneous meaning that several kinds of listeners could
--  be registered.
--
--  == Creating the observers ==
--  First the `Observers` package must be instantiated with the type being
--  observed.  In the example below, we will observe a string:
--
--    package String_Observers is new Util.Listeners.Observers (String);
--
--  == Implementing the observer ==
--  Now we must implement the string observer:
--
--    type String_Observer is new String_Observer.Observer with null record;
--    procedure Update (List : in String_Observer; Item : in String);
--
--  == Registering the observer ==
--  An instance of the string observer must now be registered in the list.
--
--    O : aliased String_Observer;
--    L.Append (O'Access);
--
--  == Publishing ==
--  Notifying the listeners is done by invoking the `Notify` operation
--  provided by the `String_Observers` package:
--
--    String_Observer.Notify (L, "Hello");
--
package Util.Listeners is

   --  The listener root interface.
   type Listener is limited interface;
   type Listener_Access is access all Listener'Class;

   --  The multi-task safe list of listeners.
   package Listener_Arrays is new Util.Concurrent.Arrays (Listener_Access);

   --  ------------------------------
   --  List of listeners
   --  ------------------------------
   --  The `List` type is a list of listeners that have been registered and must be
   --  called when a notification is sent.  The list uses the concurrent arrays thus
   --  allowing tasks to add or remove listeners while dispatching is also running.
   subtype List is Listener_Arrays.Vector;

   procedure Add_Listener (Into : in out Listener_Arrays.Vector;
                           Item : in Listener_Access) renames Listener_Arrays.Append;

   procedure Remove_Listener (Into : in out Listener_Arrays.Vector;
                              Item : in Listener_Access) renames Listener_Arrays.Remove;

end Util.Listeners;

Make the List type a subtype of Listener_Arras.Vector


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

--  This package contains the utility routines used for providing ASIS
--  warnings, debug images for ASIS types and internal debugging information.

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

with Types;       use Types;

package A4G.A_Output is

   Max_Debug_Buffer_Len : Natural := 8 * 1024;
   Debug_Buffer : String (1 .. Max_Debug_Buffer_Len);
   Debug_Buffer_Len : Natural range 0 .. Max_Debug_Buffer_Len;
   --  buffer to form debug image strings

   procedure Add (Phrase : String);
   --  Adds Phrase to Debug_Buffer and resets Debug_Buffer_Len

   procedure ASIS_Warning
     (Message : String;
      Error   : Asis.Errors.Error_Kinds := Not_An_Error);
   --  Produces a warning message (the text of the message is the string
   --  passed as an actual for the Message parameter. The effect of calling
   --  this procedure depends on which ASIS warning mode was set when ASIS was
   --  initialized. In case of Suppress nothing happens, in case of Normal
   --  Message is sent to Stderr, and in case of Treat_As_Error the warning
   --  is converted into raising ASIS_Failed, Message is sent to ASIS diagnosis
   --  and the value of the Error parameter is set to the ASIS Error Status

   function Debug_String (CUnit : Compilation_Unit) return String;
   --  Produces the string containing debug information about CUnit

   function Debug_String (Cont : Context) return String;
   --  Produces the string containing debug information about Cont

   procedure  Debug_String
     (CUnit    : Compilation_Unit;
      No_Abort : Boolean := False);
   --  Produces the string containing debug information about CUnit
   --  Forms in Debug_Buffer the string containing debug information about
   --  the argument unit. If No_Abort is set ON, then any exception raised
   --  inside this procedure is suppressed and the message about suppressed
   --  exception is added to the result string. This is needed to avoid
   --  circularity during reporting of ASIS implementation bug.

   procedure Debug_String
     (E        : Element;
      No_Abort : Boolean := False);
   --  Forms in Debug_Buffer the string containing debug information about E
   --  If No_Abort is set ON, then any exception raised inside this procedure
   --  is suppressed and the message about suppressed exception is added to
   --  the result string. This is needed to avoid circularity during reporting
   --  of ASIS implementation bug.

   procedure Write_Node (N : Node_Id; Prefix : String := "");
   --  outputs the tree node attributes without using any facilities
   --  from the GNAT Treepr package. The string passed as an actual for
   --  Prefix is outputted in the beginning of every string

end A4G.A_Output;

Add the ASIS file $i

Add the ASIS file $i


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

package body Security.OAuth.File_Registry is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in File_Principal) return String is
   begin
      return To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   --  ------------------------------
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class is
      Pos : Application_Maps.Cursor := Realm.Applications.Find (Client_Id);
   begin
      if not Application_Maps.Has_Element (Pos) then
         raise Servers.Invalid_Application;
      end if;
      return Application_Maps.Element (Pos);
   end Find_Application;

   --  ------------------------------
   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   --  ------------------------------
   overriding
   procedure Authenticate (Realm     : in out File_Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is
      Pos : constant Token_Maps.Cursor := Realm.Tokens.Find (Token);
   begin
      if Token_Maps.Has_Element (Pos) then
         Auth := Token_Maps.Element (Pos).all'Access;
      else
         Auth := null;
      end if;
      Cacheable := True;
   end Authenticate;

   --  ------------------------------
   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   --  ------------------------------
   overriding
   function Authorize (Realm : in File_Realm_Manager;
                       App   : in Servers.Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is
   begin
      return To_String (File_Principal (Auth.all).Token);
   end Authorize;

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is
      Result : File_Principal_Access;
      Pos    : constant User_Maps.Cursor := Realm.Users.Find (Username);
   begin
      if not User_Maps.Has_Element (Pos) then
         Auth := null;
         return;
      end if;
      if Password /= User_Maps.Element (Pos) then
         Auth := null;
         return;
      end if;
      Result := new File_Principal;
      Realm.Tokens.Insert (To_String (Result.Token), Result);
      Auth := Result.all'Access;
   end Verify;

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is
   begin
      null;
   end Verify;

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access) is
   begin
      if Auth /= null and then Auth.all in File_Principal'Class then
         Realm.Tokens.Delete (To_String (File_Principal (Auth.all).Token));
      end if;
   end Revoke;

end Security.OAuth.File_Registry;

Implement a simple file-base application and user realm for the OAuth server side


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

   use type Interfaces.Unsigned_32;
   use type Interfaces.Unsigned_64;
   use type Interfaces.C.size_t;

   function To_WSTR (Value : in String) return Wchar_Ptr is
      Result : constant Wchar_Ptr := new Interfaces.C.wchar_array (0 .. Value'Length + 1);
      Pos    : Interfaces.C.size_t := 0;
   begin
      for C of Value loop
         Result (Pos)
           := Interfaces.C.To_C (Ada.Characters.Conversions.To_Wide_Character (C));
         Pos := Pos + 1;
      end loop;
      Result (Pos) := Interfaces.C.wide_nul;
      return Result;
   end To_WSTR;

   function Sys_SetFilePointerEx (Fs : in File_Type;
                                  Offset : in Util.Systems.Types.off_t;
                                  Result : access Util.Systems.Types.off_t;
                                  Mode   : in Util.Systems.Types.Seek_Mode) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "SetFilePointerEx";

   function Sys_Lseek (Fs : in File_Type;
                       Offset : in Util.Systems.Types.off_t;
                       Mode   : in Util.Systems.Types.Seek_Mode)
                       return Util.Systems.Types.off_t is
      Result : aliased Util.Systems.Types.off_t;
   begin
      if Sys_SetFilePointerEx (Fs, Offset, Result'Access, Mode) /= 0 then
         return Result;
      else
         return -1;
      end if;
   end Sys_Lseek;

   function Sys_GetFileSizeEx (Fs : in File_Type;
                               Result : access Util.Systems.Types.off_t) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetFileSizeEx";

   function Sys_GetFileTime (Fs : in File_Type;
                             Create     : access FileTime;
                             AccessTime : access FileTime;
                             ModifyTime : access FileTime) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "GetFileSizeEx";

   TICKS_PER_SECOND : constant := 10000000;
   EPOCH_DIFFERENCE : constant := 11644473600;

   function To_Time (Time : in FileTime) return Types.Time_Type is
      Value : Interfaces.Unsigned_64;
   begin
      Value := Interfaces.Shift_Left (Interfaces.Unsigned_64 (Time.dwHighDateTime), 32);
      Value := Value + Interfaces.Unsigned_64 (Time.dwLowDateTime);
      Value := Value / TICKS_PER_SECOND;
      Value := Value - EPOCH_DIFFERENCE;
      return Types.Time_Type (Value);
   end To_Time;

   function Sys_Fstat (Fs : in File_Type;
                       Stat : access Util.Systems.Types.Stat_Type) return Integer is
      Size          : aliased Util.Systems.Types.off_t;
      Creation_Time : aliased FileTime;
      Access_Time   : aliased FileTime;
      Write_Time    : aliased FileTime;
   begin
      Stat.st_dev := 0;
      Stat.st_ino := 0;
      Stat.st_mode := 0;
      Stat.st_nlink := 0;
      Stat.st_uid := 0;
      Stat.st_gid := 0;
      Stat.st_rdev := 0;
      Stat.st_atime := 0;
      Stat.st_mtime := 0;
      Stat.st_ctime := 0;
      if Sys_GetFileSizeEx (Fs, Size'Access) = 0 then
         return -1;
      end if;
      if Sys_GetFileTime (Fs, Creation_Time'Access, Access_Time'Access, Write_Time'Access) = 0 then
         return -1;
      end if;
      Stat.st_size := Size;
      Stat.st_ctime := To_Time (Creation_Time);
      Stat.st_mtime := To_Time (Write_Time);
      Stat.st_atime := To_Time (Access_Time);
      return 0;
   end Sys_Fstat;

   --  Open a file
   function Sys_Open (Path  : in Ptr;
                      Flags : in Interfaces.C.int;
                      Mode  : in Util.Systems.Types.mode_t) return File_Type is
      pragma Unreferenced (Mode);

      function Has_Flag (M : in Interfaces.C.int;
                         F : in Interfaces.C.int) return Boolean
        is ((Interfaces.Unsigned_32 (M) and Interfaces.Unsigned_32 (F)) /= 0);

      Sec            : aliased Security_Attributes;
      Result         : File_Type;
      Desired_Access : DWORD;
      Share_Mode     : DWORD := FILE_SHARE_READ + FILE_SHARE_WRITE;
      Creation       : DWORD;
      WPath          : Wchar_Ptr;
   begin
      WPath := To_WSTR (Interfaces.C.Strings.Value (Path));
      Sec.Length := Security_Attributes'Size / 8;
      Sec.Security_Descriptor := System.Null_Address;
      Sec.Inherit := True;

      if Has_Flag (Flags, O_WRONLY) then
         Desired_Access := GENERIC_WRITE;
      elsif Has_Flag (Flags, O_RDWR) then
         Desired_Access := GENERIC_READ + GENERIC_WRITE;
      else
         Desired_Access := GENERIC_READ;
      end if;
      if Has_Flag (Flags, O_CREAT) then
         if Has_Flag (Flags, O_EXCL) then
            Creation := CREATE_NEW;
         else
            Creation := CREATE_ALWAYS;
         end if;
      else
         Creation := OPEN_EXISTING;
      end if;
      if Has_Flag (Flags, O_APPEND) then
         Desired_Access := FILE_APPEND_DATA;
      end if;
      if Has_Flag (Flags, O_EXCL) then
         Share_Mode := 0;
      end if;
      Result := Create_File (WPath.all'Address,
                             Desired_Access,
                             Share_Mode,
                             Sec'Unchecked_Access,
                             Creation,
                             FILE_ATTRIBUTE_NORMAL,
                             NO_FILE);

      Free (WPath);
      return Result;
   end Sys_Open;

   function Sys_SetEndOfFile (Fs : in File_Type) return BOOL
     with Import => True, Convention => Stdcall, Link_Name => "SetEndOfFile";

   function Sys_Ftruncate (Fs : in File_Type;
                           Length : in Util.Systems.Types.off_t) return Integer is
   begin
      if Sys_Lseek (Fs, Length, Util.Systems.Types.SEEK_SET) < 0 then
         return -1;
      end if;
      if Sys_SetEndOfFile (Fs) = 0 then
         return -1;
      end if;
      return 0;
   end Sys_Ftruncate;

   function Sys_Fchmod (Fd   : in File_Type;
                        Mode : in Util.Systems.Types.mode_t) return Integer is
      pragma Unreferenced (Fd, Mode);
   begin
      return 0;
   end Sys_Fchmod;

   --  Close a file
   function Sys_Close (Fd : in File_Type) return Integer is
   begin
      if Close_Handle (Fd) = 0 then
         return -1;
      else
         return 0;
      end if;
   end Sys_Close;

end Util.Systems.Os;

Implement Sys_Open, Sys_Ftruncate, Sys_Fstat, Sys_Close on top of Windows file HANDLE


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

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Target_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event_Type;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

end MAT.Events.Tools;

Implement the MAT.Events.Tools package with the Find operation


-----------------------------------------------------------------------
--  components-widgets-likes -- Social Likes Components
--  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.Locales;
with Util.Beans.Objects;
with Util.Strings.Tokenizers;

with ASF.Requests;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Likes is

   FB_LAYOUT_ATTR      : aliased constant String := "data-layout";
   FB_SHOW_FACES_ATTR  : aliased constant String := "data-show-faces";
   FB_WIDTH_ATTR       : aliased constant String := "data-width";
   FB_ACTION_ATTR      : aliased constant String := "data-action";
   FB_FONT_ATTR        : aliased constant String := "data-font";
   FB_COlORSCHEME_ATTR : aliased constant String := "data-colorscheme";
   FB_REF_ATTR         : aliased constant String := "data-ref";
   FB_KIDS_ATTR        : aliased constant String := "data-kid_directed_site";

   FACEBOOK_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;
   FACEBOOK_SCRIPT_ATTRIBUTE : constant String := "asf.widgets.facebook.script";

   type Like_Generator_Binding is record
      Name      : Util.Strings.Name_Access;
      Generator : Like_Generator_Access;
   end record;

   type Like_Generator_Array is array (1 .. MAX_LIKE_GENERATOR) of Like_Generator_Binding;

   FB_NAME      : aliased constant String := "facebook";
   FB_GENERATOR : aliased Facebook_Like_Generator;

   Generators : Like_Generator_Array := (1 => (FB_NAME'Access, FB_GENERATOR'Access),
                                         others => (null, null));

   --  ------------------------------
   --  Render the facebook like button according to the component attributes.
   --  ------------------------------
   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is
      Writer  : constant Contexts.Writer.Response_Writer_Access := Context.Get_Response_Writer;
      Request : constant ASF.Requests.Request_Access := Context.Get_Request;
   begin
      if not Context.Is_Ajax_Request and then
        Util.Beans.Objects.Is_Null (Request.Get_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE)) then

         Request.Set_Attribute (FACEBOOK_SCRIPT_ATTRIBUTE, Util.Beans.Objects.To_Object (True));
         Writer.Queue_Script ("(function(d, s, id) { var js, fjs = d.getElementsByTagName(s)[0];"
                              & "if (d.getElementById(id)) return;"
                              & "js = d.createElement(s); js.id = id;"
                              & "js.src = ""//connect.facebook.net/");
         Writer.Queue_Script (Util.Locales.To_String (Context.Get_Locale));
         Writer.Queue_Script ("/all.js#xfbml=1&;appId=116337738505130");
         Writer.Queue_Script (Generator.App_Id);
         Writer.Queue_Script (""";fjs.parentNode.insertBefore(js, fjs);"
                              & "}(document, 'script', 'facebook-jssdk'));");
         Writer.Start_Element ("div");
         Writer.Write_Attribute ("id", "fb-root");
         Writer.End_Element ("div");
      end if;
      Writer.Start_Element ("div");
      Writer.Write_Attribute ("class", "fb-like");
      Writer.Write_Attribute ("data-href", Href);
      Writer.Write_Attribute ("data-send", "true");
      UI.Render_Attributes (Context, FACEBOOK_ATTRIBUTE_NAMES, Writer);
      Writer.End_Element ("div");
   end Render_Like;

   --  ------------------------------
   --  Get the link to submit in the like action.
   --  ------------------------------
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String is
      Href : constant String := UI.Get_Attribute ("href", Context, "");
   begin
      if Href'Length > 0 then
         return Href;
      else
         return Context.Get_Request.Get_Request_URI;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Render an image with the source link created from an email address to the Gravatars service.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class) is

   begin
      if UI.Is_Rendered (Context) then
         declare
            Kind : constant String := UI.Get_Attribute ("type", Context, "");
            Href : constant String := UILike'Class (UI).Get_Link (Context);

            procedure Render (Name : in String; Done : out Boolean);

            procedure Render (Name : in String;
                              Done : out Boolean) is
               use type Util.Strings.Name_Access;
            begin
               Done := False;
               for I in Generators'Range loop
                  exit when Generators (I).Name = null;
                  if Generators (I).Name.all = Name then
                     Generators (I).Generator.Render_Like (UI, Href, Context);
                     return;
                  end if;
               end loop;
               UI.Log_Error ("Like type {0} is not recognized", Name);
            end Render;

         begin
            if Kind'Length = 0 then
               UI.Log_Error ("The like type is empty.");
            else
               Util.Strings.Tokenizers.Iterate_Tokens (Content => Kind, Pattern => ",",
                                                       Process => Render'Access);
            end if;
         end;
      end if;
   end Encode_Begin;

   --  ------------------------------
   --  Register the like generator under the given name.
   --  ------------------------------
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access) is
      use type Util.Strings.Name_Access;
   begin
      for I in Generators'Range loop
         if Generators (I).Name = null then
            Generators (I).Name := Name;
            Generators (I).Generator := Generator;
            return;
         end if;
      end loop;
   end Register_Like;

begin
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_LAYOUT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_SHOW_FACES_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_WIDTH_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_ACTION_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_FONT_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_COlORSCHEME_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_REF_ATTR'Access);
   FACEBOOK_ATTRIBUTE_NAMES.Insert (FB_KIDS_ATTR'Access);
end ASF.Components.Widgets.Likes;

Implement the <w:like> button with Facebook like support


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

   type Memory_Servant is new MAT.Readers.Reader_Base with record
      Data  : MAT.Memory.Targets.Client_Memory;
--        Slots : Client_Memory_Ref;
--        Impl        : Client_Memory_Ref;
   end record;
   --  The memory servant is a proxy for the generic communication
   --  channel to process incomming events (such as memory allocations).

   overriding
   procedure Dispatch (For_Servant : in out Memory_Servant;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Msg         : in out MAT.Readers.Message);

   procedure Bind (For_Servant : in out Memory_Servant);
   --  Bind the servant with the object adapter to register the
   --  events it recognizes.

end MAT.Memory.Readers;

Package to read the memory events

Package to read the memory events


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

package body ASF.Rest.Definition is

   overriding
   procedure Dispatch (Handler : in Descriptor;
                       Req     : in out ASF.Rest.Request'Class;
                       Reply   : in out ASF.Rest.Response'Class) is
      Object : Object_Type;
   begin
      Handler.Handler (Object, Req, Reply);
   end Dispatch;

   package body Definition is
      P : aliased String := Pattern;
   begin
      Instance.Method     := Method;
      Instance.Permission := Permission;
      Instance.Handler    := Handler;
      Instance.Pattern    := P'Access;
      ASF.Rest.Register (Entries, Instance'Access);
   end Definition;

end ASF.Rest.Definition;

Implement the Rest definition package to dispatch the request to the API handler


-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  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.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is new Util.Serialize.IO.JSON.Parser with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse_String (Content);
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with null record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                      Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
   end Read_JSON;

end Util.Properties.JSON;

Implement reading JSON content and putting it in property manager


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

with Util.Tests;

package MAT.Expressions.Tests is

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

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

   procedure Test_Parse_Expression (T : in out Test);

end MAT.Expressions.Tests;

Add unit tests for MAT.Expressions

Add unit tests for MAT.Expressions


-----------------------------------------------------------------------
--  awa-commands -- AWA commands for server or admin tool
--  Copyright (C) 2019, 2020 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
with Util.Log.Loggers;
with AWA.Applications.Configs;
with Keystore.Passwords.Input;
with Keystore.Passwords.Files;
with Keystore.Passwords.Unsafe;
with Keystore.Passwords.Cmds;
package body AWA.Commands is

   use type Keystore.Passwords.Provider_Access;
   use type Keystore.Header_Slot_Count_Type;
   use type Keystore.Passwords.Keys.Key_Provider_Access;

   Log     : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Commands");

   procedure Load_Configuration (Context : in out Context_Type) is
   begin
      begin
         Context.File_Config.Load_Properties (Context.Config_File.all);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read application configuration file {0}",
                       Context.Config_File.all);
      end;
      if Context.File_Config.Exists (GPG_CRYPT_CONFIG) then
         Context.GPG.Set_Encrypt_Command (Context.File_Config.Get (GPG_CRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_DECRYPT_CONFIG) then
         Context.GPG.Set_Decrypt_Command (Context.File_Config.Get (GPG_DECRYPT_CONFIG));
      end if;
      if Context.File_Config.Exists (GPG_LIST_CONFIG) then
         Context.GPG.Set_List_Key_Command (Context.File_Config.Get (GPG_LIST_CONFIG));
      end if;
      Context.Config.Randomize := not Context.Zero;
   end Load_Configuration;

   --  ------------------------------
   --  Returns True if a keystore is used by the configuration and must be unlocked.
   --  ------------------------------
   function Use_Keystore (Context : in Context_Type) return Boolean is
   begin
      if Context.Wallet_File'Length > 0 then
         return True;
      end if;

      return Context.File_Config.Exists ("keystore.path");
   end Use_Keystore;

   --  ------------------------------
   --  Open the keystore file using the password password.
   --  ------------------------------
   procedure Open_Keystore (Context    : in out Context_Type) is
   begin
      Setup_Password_Provider (Context);
      Setup_Key_Provider (Context);

      Context.Wallet.Open (Path      => Context.Get_Keystore_Path,
                           Data_Path => Context.Data_Path.all,
                           Config    => Context.Config,
                           Info      => Context.Info);

      if not Context.No_Password_Opt or else Context.Info.Header_Count = 0 then
         if Context.Key_Provider /= null then
            Context.Wallet.Set_Master_Key (Context.Key_Provider.all);
         end if;
         if Context.Provider = null then
            Context.Provider := Keystore.Passwords.Input.Create (-("Enter password: "), False);
         end if;

         Context.Wallet.Unlock (Context.Provider.all, Context.Slot);
      else
         Context.GPG.Load_Secrets (Context.Wallet);

         Context.Wallet.Set_Master_Key (Context.GPG);

         Context.Wallet.Unlock (Context.GPG, Context.Slot);
      end if;

      Keystore.Properties.Initialize (Context.Secure_Config, Context.Wallet'Unchecked_Access);
      AWA.Applications.Configs.Merge (Context.App_Config,
                                      Context.File_Config,
                                      Context.Secure_Config,
                                      "");
   end Open_Keystore;

   --  ------------------------------
   --  Configure the application by loading its configuration file and merging it with
   --  the keystore file if there is one.
   --  ------------------------------
   procedure Configure (Application : in out AWA.Applications.Application'Class;
                        Name        : in String;
                        Context     : in out Context_Type) is
      Path : constant String := AWA.Applications.Configs.Get_Config_Path (Name);
   begin
      begin
         Context.File_Config.Load_Properties (Path);
      exception
         when Ada.IO_Exceptions.Name_Error =>
            null;
      end;

      if Context.Use_Keystore then
         Open_Keystore (Context);
      else
         Context.App_Config := Context.File_Config;
      end if;
      Application.Initialize (Context.App_Config, Context.Factory);
   end Configure;

   --  ------------------------------
   --  Initialize the commands.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Context_Type) is
   begin
      GC.Set_Usage (Config => Context.Command_Config,
                    Usage  => "[switchs] command [arguments]",
                    Help   => -("akt - tool to store and protect your sensitive data"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Version'Access,
                        Switch => "-V",
                        Long_Switch => "--version",
                        Help   => -("Print the version"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Verbose'Access,
                        Switch => "-v",
                        Long_Switch => "--verbose",
                        Help   => -("Verbose execution mode"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Debug'Access,
                        Switch => "-vv",
                        Long_Switch => "--debug",
                        Help   => -("Enable debug execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Dump'Access,
                        Switch => "-vvv",
                        Long_Switch => "--debug-dump",
                        Help   => -("Enable debug dump execution"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Zero'Access,
                        Switch => "-z",
                        Long_Switch => "--zero",
                        Help   => -("Erase and fill with zeros instead of random values"));
      GC.Define_Switch (Config => Context.Command_Config,
                        Output => Context.Config_File'Access,
                        Switch => "-c:",
                        Long_Switch => "--config=",
                        Argument => "PATH",
                        Help   => -("Defines the path for configuration file"));
      GC.Initialize_Option_Scan (Stop_At_First_Non_Switch => True);

--      Driver.Set_Description (-("akt - tool to store and protect your sensitive data"));
--     Driver.Set_Usage (-("[-V] [-v] [-vv] [-vvv] [-c path] [-t count] [-z] " &
--                          "<command> [<args>]" & ASCII.LF &
--                          "where:" & ASCII.LF &
--                          "  -V           Print the tool version" & ASCII.LF &
--                          "  -v           Verbose execution mode" & ASCII.LF &
--                          "  -vv          Debug execution mode" & ASCII.LF &
--                          "  -vvv         Dump execution mode" & ASCII.LF &
--                          "  -c path      Defines the path for akt " &
--                          "global configuration" & ASCII.LF &
--                          "  -t count     Number of threads for the " &
--                          "encryption/decryption process" & ASCII.LF &
--                          "  -z           Erase and fill with zeros instead of random values"));
--      Driver.Add_Command ("help",
--                          -("print some help"),
--                          Help_Command'Access);
   end Initialize;

   --  ------------------------------
   --  Setup the command before parsing the arguments and executing it.
   --  ------------------------------
   procedure Setup (Config  : in out GC.Command_Line_Configuration;
                    Context : in out Context_Type) is
   begin
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_File'Access,
                        Switch => "-k:",
                        Long_Switch => "--keystore=",
                        Argument => "PATH",
                        Help   => -("Defines the path for the keystore file"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Data_Path'Access,
                        Switch => "-d:",
                        Long_Switch => "--data-path=",
                        Argument => "PATH",
                        Help   => -("The directory which contains the keystore data blocks"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_File'Access,
                        Long_Switch => "--passfile=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passfd=",
                        Argument => "NUM",
                        Help   => -("Read the password from the pipe with"
                          & " the given file descriptor"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Long_Switch => "--passsocket=",
                        Help   => -("The password is passed within the socket connection"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Env'Access,
                        Long_Switch => "--passenv=",
                        Argument => "NAME",
                        Help   => -("Read the environment variable that contains"
                        & " the password (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Unsafe_Password'Access,
                        Switch => "-p:",
                        Long_Switch => "--password=",
                        Help   => -("The password is passed within the command line (not safe)"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Askpass'Access,
                        Long_Switch => "--passask",
                        Help   => -("Run the ssh-askpass command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Password_Command'Access,
                        Long_Switch => "--passcmd=",
                        Argument => "COMMAND",
                        Help   => -("Run the command to get the password"));
      GC.Define_Switch (Config => Config,
                        Output => Context.Wallet_Key_File'Access,
                        Long_Switch => "--wallet-key-file=",
                        Argument => "PATH",
                        Help   => -("Read the file that contains the wallet keys"));
   end Setup;

   procedure Setup_Password_Provider (Context : in out Context_Type) is
   begin
      if Context.Password_Askpass then
         Context.Provider := Keystore.Passwords.Cmds.Create ("ssh-askpass");
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Password_File'Length > 0 then
         Context.Provider := Keystore.Passwords.Files.Create (Context.Password_File.all);
      elsif Context.Password_Command'Length > 0 then
         Context.Provider := Keystore.Passwords.Cmds.Create (Context.Password_Command.all);
      elsif Context.Unsafe_Password'Length > 0 then
         Context.Provider := Keystore.Passwords.Unsafe.Create (Context.Unsafe_Password.all);
      else
         Context.No_Password_Opt := True;
      end if;
      Context.Key_Provider := Keystore.Passwords.Keys.Create (Keystore.DEFAULT_WALLET_KEY);
   end Setup_Password_Provider;

   procedure Setup_Key_Provider (Context : in out Context_Type) is
   begin
      if Context.Wallet_Key_File'Length > 0 then
         Context.Key_Provider := Keystore.Passwords.Files.Create (Context.Wallet_Key_File.all);
      end if;
   end Setup_Key_Provider;

   --  ------------------------------
   --  Get the keystore file path.
   --  ------------------------------
   function Get_Keystore_Path (Context : in out Context_Type) return String is
   begin
      if Context.Wallet_File'Length > 0 then
         Context.First_Arg := 1;
         return Context.Wallet_File.all;
      else
         raise Error with "No keystore path";
      end if;
   end Get_Keystore_Path;

   overriding
   procedure Finalize (Context : in out Context_Type) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Keystore.Passwords.Provider'Class,
                                        Name   => Keystore.Passwords.Provider_Access);
   begin
      GC.Free (Context.Command_Config);
      Free (Context.Provider);
   end Finalize;

end AWA.Commands;

Implement operations for the AWA.Commands package


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

with Asis;

with Types;  use Types;

package A4G.Skip_TB is

   --  This package encapsulates routines which is used in finding the end of
   --  an Element Span tp scip all the "syntax sugar", such as ";", ")",
   --  "end if", "end Unit_Name" etc.

   function Skip_Trailing_Brackets
     (E : Asis.Element;
      S : Source_Ptr)
      return Source_Ptr;

   --  This function encapsulates all the cases when different kinds of
   --  "syntax sugar" should be skiped, being implemented as a look-up
   --  table for Internal_Element_Kinds. It returns the location of the
   --  very last character of the image of E, provided that S is set to
   --  point to iys last component. If a given Element has several levels
   --  of subcomponents, this function is called each time when the
   --  next right-most component is traversed in the recursive processing
   --  defined by A4G.Span_End.Nonterminal_Component.

   function Needs_Extra_Parentheses (E : Asis.Element) return Boolean;
   --  This function detects if we need an extra parenthesis in the qualified
   --  expression in the situation like this
   --    Var : String := String'((1 => C));
   --  The problem is that from the point of view of ASIS Element hierarchy
   --  it there is no difference between this situation and
   --    Var : String := String'(1 => C);
   --  because we do not have A_Parenthesized_Expression in the first case,
   --  we just have to decompose the qualified expression according to the
   --  syntax rule: subtype_mark'(expression), and the outer pair of
   --  parenthesis belongs to a qualified expression, and the inner - to an
   --  enclosed aggregate.
   --  We need this function in the spec to use it in gnatpp.

end A4G.Skip_TB;

Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  awa-counters-definition -- Counter definition
--  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.
-----------------------------------------------------------------------

--  The <tt>AWA.Counters.Definition</tt> package is instantiated for each counter definition.
generic
   Table : ADO.Schemas.Class_Mapping_Access;
   Field : String;
package AWA.Counters.Definition is

   Def_Name : aliased constant String := Field;

   package Def is new Counter_Arrays.Definition (Counter_Def '(Table, Def_Name'Access));

   --  Get the counter definition index.
   function Index return Counter_Index_Type renames Def.Kind;

end AWA.Counters.Definition;

Define the generic package for a counter definition


-----------------------------------------------------------------------
--  wiki-render-html -- Wiki HTML 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.Strings.Wide_Wide_Unbounded;

with Wiki.Documents;
with Wiki.Writers;

--  == HTML Renderer ==
--  The <tt>Text_Renderer</tt> allows to render a wiki document into a text content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Html is

   use Ada.Strings.Wide_Wide_Unbounded;

   --  ------------------------------
   --  Wiki to HTML writer
   --  ------------------------------
   type Html_Renderer is new Wiki.Documents.Document_Reader with private;

   --  Set the output writer.
   procedure Set_Writer (Document : in out Html_Renderer;
                         Writer   : in Wiki.Writers.Html_Writer_Type_Access);

   --  Add a section header in the document.
   overriding
   procedure Add_Header (Document : in out Html_Renderer;
                         Header   : in Unbounded_Wide_Wide_String;
                         Level    : in Positive);

   --  Add a line break (
).
   overriding
   procedure Add_Line_Break (Document : in out Html_Renderer);

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

   --  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 Html_Renderer;
                             Level    : in Natural);

   --  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 Html_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add an horizontal rule (
).
   overriding
   procedure Add_Horizontal_Rule (Document : in out Html_Renderer);

   --  Add a link.
   overriding
   procedure Add_Link (Document : in out Html_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);

   --  Add an image.
   overriding
   procedure Add_Image (Document    : in out Html_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);

   --  Add a quote.
   overriding
   procedure Add_Quote (Document : in out Html_Renderer;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String);

   --  Add a text block with the given format.
   overriding
   procedure Add_Text (Document : in out Html_Renderer;
                       Text     : in Unbounded_Wide_Wide_String;
                       Format   : in Wiki.Documents.Format_Map);

   --  Add a text block that is pre-formatted.
   procedure Add_Preformatted (Document : in out Html_Renderer;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Renderer);

private

   procedure Close_Paragraph (Document : in out Html_Renderer);
   procedure Open_Paragraph (Document : in out Html_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   type Html_Renderer is new Wiki.Documents.Document_Reader with record
      Writer         : Wiki.Writers.Html_Writer_Type_Access := null;
      Format         : Wiki.Documents.Format_Map := (others => False);
      Has_Paragraph  : Boolean := False;
      Need_Paragraph : Boolean := False;
      Current_Level  : Natural := 0;
      List_Styles    : List_Style_Array := (others => False);
      Has_Item       : Boolean := False;
      Quote_Level    : Natural := 0;
   end record;

end Wiki.Render.Html;

Define the renderer to transform a wiki text in HTML