-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011 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.Contexts;
with Util.Strings.Transforms;
package body Util.Serialize.Mappers.Record_Mapper is

   Key : Util.Serialize.Contexts.Data_Key;

   --  -----------------------
   --  Get the element object.
   --  -----------------------
   function Get_Element (Data : in Element_Data) return Element_Type_Access is
   begin
      return Data.Element;
   end Get_Element;

   --  -----------------------
   --  Set the element object.
   --  -----------------------
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access) is
   begin
      Data.Element := Element;
   end Set_Element;

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
      D : constant Contexts.Data_Access := Ctx.Get_Data (Key);
   begin
      if not (D.all in Element_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Element_Data_Access := Element_Data'Class (D.all)'Access;
      begin
         if DE.Element = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         Handler.Execute (Map, DE.Element.all, Value);
      end;
   end Execute;

   --  -----------------------
   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   --  -----------------------
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields) is
      Map : constant Attribute_Mapping_Access := new Attribute_Mapping;
   begin
      Map.Index   := Field;
      Into.Add_Mapping (Path, Map.all'Access);
   end Add_Mapping;

   --  -----------------------
   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   --  -----------------------
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object) is
     M : Proxy_Mapper_Access := new Proxy_Mapper;
   begin
      M.Mapper  := Map;
      M.Execute := Execute'Access;
      M.Is_Proxy_Mapper := True;
      Into.Mapping.Insert (Key => Path, New_Item => M.all'Access);
   end Add_Mapping;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access) is
   begin
      Into.Get_Member := Getter;
   end Bind;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object) is
   begin
      Set_Member (Element, Attr.Index, Value);
   end Set_Member;

   --  -----------------------
   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.
   --  -----------------------
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object) is
   begin
      if not (Attr in Attribute_Mapping) then
         raise Mapping_Error;
      end if;
      Attribute_Mapping (Attr).Set_Member (Element, Value);
   end Set_Member;

   --  -----------------------
   --  Set the element in the context.
   --  -----------------------
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access) is
      Data_Context : constant Element_Data_Access := new Element_Data;
   begin
      Data_Context.Element := Element;
      Ctx.Set_Data (Key => Key, Content => Data_Context.all'Access);
   end Set_Context;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   overriding
   function Find_Mapping (Controller : in Proxy_Mapper;
                          Name       : in String) return Mapping_Access is
      Result : Mapping_Access := Controller.Mapper.Find_Mapping (Name);
   begin
      if Result /= null then
         return Result;
      else
         return Util.Serialize.Mappers.Mapper (Controller).Find_Mapping (Name);
      end if;
   end Find_Mapping;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String) return Util.Serialize.Mappers.Mapper_Access is
      Result : Util.Serialize.Mappers.Mapper_Access := Controller.Mapper.Find_Mapper (Name);
   begin
      if Result /= null then
         return Result;
      else
         return Util.Serialize.Mappers.Mapper (Controller).Find_Mapper (Name);
      end if;
   end Find_Mapper;

   --  -----------------------
   --  Copy the mapping definitions defined by From into the target mapper
   --  and use the Process procedure to give access to the element.
   --  -----------------------
   procedure Copy (Into    : in out Mapper;
                   From    : in Mapper;
                   Process : in Process_Object) is
      Iter : Mapping_Map.Cursor := From.Rules.First;
   begin
      Into.Get_Member := From.Get_Member;
      while Mapping_Map.Has_Element (Iter) loop
         declare
            Path : constant String := Mapping_Map.Key (Iter);
            E    : constant Mapping_Access := Mapping_Map.Element (Iter);
            Map  : constant Attribute_Mapping_Access := Attribute_Mapping'Class (E.all)'Access;
            N    : constant Attribute_Mapping_Access := new Attribute_Mapping;
         begin
            N.Index := Map.Index;
            Into.Add_Mapping (Path, N.all'Access);
         end;
         Mapping_Map.Next (Iter);
      end loop;
   end Copy;

   --  -----------------------
   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   --  -----------------------
   procedure Add_Default_Mapping (Into : in out Mapper) is
      use Util.Strings.Transforms;
   begin
      for Field in Fields'Range loop
         declare
            Name : constant String := To_Lower_Case (Fields'Image (Field));
         begin
            if Name (Name'First .. Name'First + 5) = "field_" then
               Into.Add_Mapping (Name (Name'First + 6 .. Name'Last), Field);
            else
               Into.Add_Mapping (Name, Field);
            end if;
         end;
      end loop;
   end Add_Default_Mapping;

   --  -----------------------
   --  Write the element on the stream using the mapper description.
   --  -----------------------
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type) is
      Iter : Mapping_Map.Cursor := Handler.Rules.First;
   begin
      Stream.Start_Entity ("");
      while Mapping_Map.Has_Element (Iter) loop
         declare
            Path : constant String := Mapping_Map.Key (Iter);
            E    : constant Mapping_Access := Mapping_Map.Element (Iter);
            Map  : constant Attribute_Mapping_Access := Attribute_Mapping'Class (E.all)'Access;
            Val  : constant Util.Beans.Objects.Object := Handler.Get_Member (Element, Map.Index);
         begin
            Stream.Write_Attribute (Name  => Path, Value => Val);
         end;
         Mapping_Map.Next (Iter);
      end loop;
      Stream.End_Entity ("");
   end Write;

begin
   --  Allocate the unique data key.
   Util.Serialize.Contexts.Allocate (Key);
end Util.Serialize.Mappers.Record_Mapper;

-----------------------------------------------------------------------
--  Util.Serialize.Mappers.Record_Mapper -- Mapper for record types
--  Copyright (C) 2010, 2011 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.Contexts;
with Util.Strings.Transforms;
package body Util.Serialize.Mappers.Record_Mapper is

   Key : Util.Serialize.Contexts.Data_Key;

   --  -----------------------
   --  Get the element object.
   --  -----------------------
   function Get_Element (Data : in Element_Data) return Element_Type_Access is
   begin
      return Data.Element;
   end Get_Element;

   --  -----------------------
   --  Set the element object.
   --  -----------------------
   procedure Set_Element (Data    : in out Element_Data;
                          Element : in Element_Type_Access) is
   begin
      Data.Element := Element;
   end Set_Element;

   --  -----------------------
   --  Execute the mapping operation on the object associated with the current context.
   --  The object is extracted from the context and the Execute operation is called.
   --  -----------------------
   procedure Execute (Handler : in Mapper;
                      Map     : in Mapping'Class;
                      Ctx     : in out Util.Serialize.Contexts.Context'Class;
                      Value   : in Util.Beans.Objects.Object) is
      D : constant Contexts.Data_Access := Ctx.Get_Data (Key);
   begin
      if not (D.all in Element_Data'Class) then
         raise Util.Serialize.Contexts.No_Data;
      end if;
      declare
         DE : constant Element_Data_Access := Element_Data'Class (D.all)'Access;
      begin
         if DE.Element = null then
            raise Util.Serialize.Contexts.No_Data;
         end if;
         Handler.Execute (Map, DE.Element.all, Value);
      end;
   end Execute;

   --  -----------------------
   --  Add a mapping for setting a member.  When the attribute rule defined by Path
   --  is matched, the Set_Member procedure will be called with the value and the
   --  Field identification.
   --  -----------------------
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Field : in Fields) is
      Map : constant Attribute_Mapping_Access := new Attribute_Mapping;
   begin
      Map.Index   := Field;
      Into.Add_Mapping (Path, Map.all'Access);
   end Add_Mapping;

   --  -----------------------
   --  Add a mapping associated with the path and described by a mapper object.
   --  The Proxy procedure is in charge of giving access to the target
   --  object used by the Map mapper.
   --  -----------------------
   procedure Add_Mapping (Into  : in out Mapper;
                          Path  : in String;
                          Map   : in Util.Serialize.Mappers.Mapper_Access;
                          Proxy : in Proxy_Object) is
     M : Proxy_Mapper_Access := new Proxy_Mapper;
   begin
      M.Mapper  := Map;
      M.Execute := Proxy;
      M.Is_Proxy_Mapper := True;
      Into.Mapping.Insert (Key => Path, New_Item => M.all'Access);
   end Add_Mapping;

   --
   procedure Bind (Into    : in out Mapper;
                   Getter  : in Get_Member_Access) is
   begin
      Into.Get_Member := Getter;
   end Bind;

   procedure Set_Member (Attr    : in Attribute_Mapping;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object) is
   begin
      Set_Member (Element, Attr.Index, Value);
   end Set_Member;

   --  -----------------------
   --  Set the attribute member described by the Attr mapping
   --  into the value passed in Element.
   --  -----------------------
   procedure Set_Member (Attr    : in Mapping'Class;
                         Element : in out Element_Type;
                         Value   : in Util.Beans.Objects.Object) is
   begin
      if not (Attr in Attribute_Mapping) then
         raise Mapping_Error;
      end if;
      Attribute_Mapping (Attr).Set_Member (Element, Value);
   end Set_Member;

   --  -----------------------
   --  Set the element in the context.
   --  -----------------------
   procedure Set_Context (Ctx     : in out Util.Serialize.Contexts.Context'Class;
                          Element : in Element_Type_Access) is
      Data_Context : constant Element_Data_Access := new Element_Data;
   begin
      Data_Context.Element := Element;
      Ctx.Set_Data (Key => Key, Content => Data_Context.all'Access);
   end Set_Context;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   overriding
   function Find_Mapping (Controller : in Proxy_Mapper;
                          Name       : in String) return Mapping_Access is
      Result : Mapping_Access := Controller.Mapper.Find_Mapping (Name);
   begin
      if Result /= null then
         return Result;
      else
         return Util.Serialize.Mappers.Mapper (Controller).Find_Mapping (Name);
      end if;
   end Find_Mapping;

   --  -----------------------
   --  Find the mapper associated with the given name.
   --  Returns null if there is no mapper.
   --  -----------------------
   overriding
   function Find_Mapper (Controller : in Proxy_Mapper;
                         Name       : in String) return Util.Serialize.Mappers.Mapper_Access is
      Result : Util.Serialize.Mappers.Mapper_Access := Controller.Mapper.Find_Mapper (Name);
   begin
      if Result /= null then
         return Result;
      else
         return Util.Serialize.Mappers.Mapper (Controller).Find_Mapper (Name);
      end if;
   end Find_Mapper;

   --  -----------------------
   --  Copy the mapping definitions defined by From into the target mapper
   --  and use the Process procedure to give access to the element.
   --  -----------------------
   procedure Copy (Into    : in out Mapper;
                   From    : in Mapper;
                   Process : in Process_Object) is
      Iter : Mapping_Map.Cursor := From.Rules.First;
   begin
      Into.Get_Member := From.Get_Member;
      while Mapping_Map.Has_Element (Iter) loop
         declare
            Path : constant String := Mapping_Map.Key (Iter);
            E    : constant Mapping_Access := Mapping_Map.Element (Iter);
            Map  : constant Attribute_Mapping_Access := Attribute_Mapping'Class (E.all)'Access;
            N    : constant Attribute_Mapping_Access := new Attribute_Mapping;
         begin
            N.Index := Map.Index;
            Into.Add_Mapping (Path, N.all'Access);
         end;
         Mapping_Map.Next (Iter);
      end loop;
   end Copy;

   --  -----------------------
   --  Build a default mapping based on the Fields enumeration.
   --  The enumeration name is used for the mapping name with the optional FIELD_
   --  prefix stripped.
   --  -----------------------
   procedure Add_Default_Mapping (Into : in out Mapper) is
      use Util.Strings.Transforms;
   begin
      for Field in Fields'Range loop
         declare
            Name : constant String := To_Lower_Case (Fields'Image (Field));
         begin
            if Name (Name'First .. Name'First + 5) = "field_" then
               Into.Add_Mapping (Name (Name'First + 6 .. Name'Last), Field);
            else
               Into.Add_Mapping (Name, Field);
            end if;
         end;
      end loop;
   end Add_Default_Mapping;

   --  -----------------------
   --  Write the element on the stream using the mapper description.
   --  -----------------------
   procedure Write (Handler : in Mapper;
                    Stream  : in out Util.Serialize.IO.Output_Stream'Class;
                    Element : in Element_Type) is
      Iter : Mapping_Map.Cursor := Handler.Rules.First;
   begin
      Stream.Start_Entity ("");
      while Mapping_Map.Has_Element (Iter) loop
         declare
            Path : constant String := Mapping_Map.Key (Iter);
            E    : constant Mapping_Access := Mapping_Map.Element (Iter);
            Map  : constant Attribute_Mapping_Access := Attribute_Mapping'Class (E.all)'Access;
            Val  : constant Util.Beans.Objects.Object := Handler.Get_Member (Element, Map.Index);
         begin
            Stream.Write_Attribute (Name  => Path, Value => Val);
         end;
         Mapping_Map.Next (Iter);
      end loop;
      Stream.End_Entity ("");
   end Write;

begin
   --  Allocate the unique data key.
   Util.Serialize.Contexts.Allocate (Key);
end Util.Serialize.Mappers.Record_Mapper;

Fix compilation

Fix compilation


Add register package

Add register package


-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011 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.Latin_1;
with Ada.IO_Exceptions;

with Util.Streams;
package body Util.Serialize.IO.JSON is

   use Ada.Strings.Unbounded;

   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      raise Parse_Error with Natural'Image (Handler.Line_Number) & ":" & Message;
   end Error;

   procedure Parse (Handler : in out Parser;
                    Stream : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      --  Put back a token in the buffer.
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type);

      --  Parse the expression buffer to find the next token.
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type);

      --  Parse a number
      procedure Parse_Number (P      : in out Parser'Class;
                              Result : out Long_Long_Integer);

      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Pairs (P : in out Parser'Class);

      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String);

      procedure Parse (P : in out Parser'Class);

      procedure Parse (P : in out Parser'Class) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         if Token /= T_LEFT_BRACE then
            P.Error ("Missing '{'");
         end if;
         Parse_Pairs (P);
         Peek (P, Token);
         if Token /= T_RIGHT_BRACE then
            P.Error ("Missing '}'");
         end if;
      end Parse;

      --  ------------------------------
      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Pairs (P : in out Parser'Class) is
         Current_Name : Unbounded_String;
         Token        : Token_Type;
      begin
         loop
            Peek (P, Token);
            if Token /= T_STRING then
               Put_Back (P, Token);
               return;
            end if;
            Current_Name := P.Token;
            Peek (P, Token);
            if Token /= T_COLON then
               P.Error ("Missing ':'");
            end if;

            Parse_Value (P, To_String (Current_Name));
            Peek (P, Token);
            if Token /= T_COMMA then
               Put_Back (P, Token);
               return;
            end if;
         end loop;
      end Parse_Pairs;

      --  ------------------------------
      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         case Token is
            when T_LEFT_BRACE =>
               P.Start_Object (Name);
               Parse_Pairs (P);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACE then
                  P.Error ("Missing '}'");
               end if;
               P.Finish_Object (Name);

                  --
            when T_LEFT_BRACKET =>
               P.Start_Array (Name);
               loop
                  Parse_Value (P, "");
                  Peek (P, Token);
                  exit when Token = T_RIGHT_BRACKET;
                  if Token /= T_COMMA then
                     P.Error ("Missing ']'");
                  end if;
               end loop;
               P.Finish_Array (Name);

            when T_NULL =>
               P.Set_Member (Name, Util.Beans.Objects.Null_Object);

            when T_NUMBER =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_STRING =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_TRUE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (True));

            when T_FALSE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (False));

            when T_EOF =>
               P.Error ("End of stream reached");
               return;

            when others =>
               P.Error ("Invalid token");
         end case;
      end Parse_Value;

      --  ------------------------------
      --  Put back a token in the buffer.
      --  ------------------------------
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type) is
      begin
         P.Pending_Token := Token;
      end Put_Back;

      --  ------------------------------
      --  Parse the expression buffer to find the next token.
      --  ------------------------------
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type) is
         C, C1 : Character;
      begin
         --  If a token was put back, return it.
         if P.Pending_Token /= T_EOF then
            Token := P.Pending_Token;
            P.Pending_Token := T_EOF;
            return;
         end if;

         if P.Has_Pending_Char then
            C := P.Pending_Char;
         else
            --  Skip white spaces
            loop
               Stream.Read (Char => C);
               if C = Ada.Characters.Latin_1.LF then
                  P.Line_Number := P.Line_Number + 1;
               else
                  exit when C /= ' '
                    and C /= Ada.Characters.Latin_1.CR and C /= Ada.Characters.Latin_1.HT;
               end if;
            end loop;
         end if;
         P.Has_Pending_Char := False;

         --  See what we have and continue parsing.
         case C is
            --  Literal string using double quotes
            --  Collect up to the end of the string and put
            --  the result in the parser token result.
         when '"' =>
            Delete (P.Token, 1, Length (P.Token));
            loop
               Stream.Read (Char => C1);
               if C1 = '\' then
                  Stream.Read (Char => C1);
                  case C1 is
                     when '"' | '\' | '/' =>
                        C := C1;

                     when 'b' =>
                        C1 := Ada.Characters.Latin_1.BS;

                     when 'f' =>
                        C1 := Ada.Characters.Latin_1.VT;

                     when 'n' =>
                        C1 := Ada.Characters.Latin_1.LF;

                     when 'r' =>
                        C1 := Ada.Characters.Latin_1.CR;

                     when 't' =>
                        C1 := Ada.Characters.Latin_1.HT;

                     when 'u' =>
                        null;

                     when others =>
                        null;
                  end case;
               elsif C1 = C then
                  Token := T_STRING;
                  return;
               end if;
               Append (P.Token, C1);
            end loop;
            P.Error ("Missing '""' to terminate the string");
            return;

            --  Number
         when '-' | '0' .. '9' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when C not in '0' .. '9';
               Append (P.Token, C);
            end loop;
            if C = '.' then
               Append (P.Token, C);
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C = 'e' or C = 'E' then
               Append (P.Token, C);
               Stream.Read (Char => C);
               if C = '+' or C = '-' then
                  Append (P.Token, C);
                  Stream.Read (Char => C);
               end if;
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;
            Token := T_NUMBER;
            return;

            --  Parse a name composed of letters or digits.
         when 'a' .. 'z' | 'A' .. 'Z' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when not (C in 'a' .. 'z' or C in 'A' .. 'Z'
                              or C in '0' .. '9' or C = '_');
               Append (P.Token, C);
            end loop;
            --  Putback the last character unless we can ignore it.
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;

            --  and empty eq false ge gt le lt ne not null true
            case Element (P.Token, 1) is
               when 'n' | 'N' =>
                  if P.Token = "null" then
                     Token := T_NULL;
                     return;
                  end if;

               when 'f' | 'F' =>
                  if P.Token = "false" then
                     Token := T_FALSE;
                     return;
                  end if;

               when 't' | 'T' =>
                  if P.Token = "true" then
                     Token := T_TRUE;
                     return;
                  end if;

               when others =>
                  null;
            end case;
            Token := T_UNKNOWN;
            return;

         when '{' =>
            Token := T_LEFT_BRACE;
            return;

         when '}' =>
            Token := T_RIGHT_BRACE;
            return;

         when '[' =>
            Token := T_LEFT_BRACKET;
            return;

         when ']' =>
            Token := T_RIGHT_BRACKET;
            return;

         when ':' =>
            Token := T_COLON;
            return;

         when ',' =>
            Token := T_COMMA;
            return;

         when others =>
            Token := T_UNKNOWN;
            return;
         end case;

      exception
         when Ada.IO_Exceptions.Data_Error =>
            Token := T_EOF;
            return;
      end Peek;

      --  ------------------------------
      --  Parse a number
      --  ------------------------------
      procedure Parse_Number (P      : in out Parser'Class;
                              Result : out Long_Long_Integer) is
         Value : Long_Long_Integer := 0;
         Num   : Long_Long_Integer;
         C     : Character;
      begin
         loop
            Stream.Read (Char => C);
            exit when C not in '0' .. '9';
            Num := Character'Pos (C) - Character'Pos ('0');
            Value := Value * 10 + Num;
         end loop;
         Result := Value;
      end Parse_Number;

   begin
      Parse (Handler);
   end Parse;

end Util.Serialize.IO.JSON;

-----------------------------------------------------------------------
--  util-serialize-io-json -- JSON Serialization Driver
--  Copyright (C) 2010, 2011 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.Latin_1;
with Ada.IO_Exceptions;

with Util.Streams;
package body Util.Serialize.IO.JSON is

   use Ada.Strings.Unbounded;

   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      raise Parse_Error with Natural'Image (Handler.Line_Number) & ":" & Message;
   end Error;

   procedure Parse (Handler : in out Parser;
                    Stream : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      --  Put back a token in the buffer.
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type);

      --  Parse the expression buffer to find the next token.
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type);

      --  Parse a number
      procedure Parse_Number (P      : in out Parser'Class;
                              Result : out Long_Long_Integer);

      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Pairs (P : in out Parser'Class);

      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String);

      procedure Parse (P : in out Parser'Class);

      procedure Parse (P : in out Parser'Class) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         if Token /= T_LEFT_BRACE then
            P.Error ("Missing '{'");
         end if;
         Parse_Pairs (P);
         Peek (P, Token);
         if Token /= T_RIGHT_BRACE then
            P.Error ("Missing '}'");
         end if;
      end Parse;

      --  ------------------------------
      --  Parse a list of members
      --  members ::= pair | pair ',' members
      --  pair    ::= string ':' value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Pairs (P : in out Parser'Class) is
         Current_Name : Unbounded_String;
         Token        : Token_Type;
      begin
         loop
            Peek (P, Token);
            if Token /= T_STRING then
               Put_Back (P, Token);
               return;
            end if;
            Current_Name := P.Token;
            Peek (P, Token);
            if Token /= T_COLON then
               P.Error ("Missing ':'");
            end if;

            Parse_Value (P, To_String (Current_Name));
            Peek (P, Token);
            if Token /= T_COMMA then
               Put_Back (P, Token);
               return;
            end if;
         end loop;
      end Parse_Pairs;

      --  ------------------------------
      --  Parse a value
      --  value   ::= string | number | object | array | true | false | null
      --  ------------------------------
      procedure Parse_Value (P    : in out Parser'Class;
                             Name : in String) is
         Token : Token_Type;
      begin
         Peek (P, Token);
         case Token is
            when T_LEFT_BRACE =>
               P.Start_Object (Name);
               Parse_Pairs (P);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACE then
                  P.Error ("Missing '}'");
               end if;
               P.Finish_Object (Name);

                  --
            when T_LEFT_BRACKET =>
               P.Start_Array (Name);
               Peek (P, Token);
               if Token /= T_RIGHT_BRACKET then
                  Put_Back (P, Token);
                  loop
                     Parse_Value (P, "");
                     Peek (P, Token);
                     exit when Token = T_RIGHT_BRACKET;
                     if Token /= T_COMMA then
                        P.Error ("Missing ']'");
                     end if;
                  end loop;
               end if;
               P.Finish_Array (Name);

            when T_NULL =>
               P.Set_Member (Name, Util.Beans.Objects.Null_Object);

            when T_NUMBER =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_STRING =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (P.Token));

            when T_TRUE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (True));

            when T_FALSE =>
               P.Set_Member (Name, Util.Beans.Objects.To_Object (False));

            when T_EOF =>
               P.Error ("End of stream reached");
               return;

            when others =>
               P.Error ("Invalid token");
         end case;
      end Parse_Value;

      --  ------------------------------
      --  Put back a token in the buffer.
      --  ------------------------------
      procedure Put_Back (P     : in out Parser'Class;
                          Token : in Token_Type) is
      begin
         P.Pending_Token := Token;
      end Put_Back;

      --  ------------------------------
      --  Parse the expression buffer to find the next token.
      --  ------------------------------
      procedure Peek (P     : in out Parser'Class;
                      Token : out Token_Type) is
         C, C1 : Character;
      begin
         --  If a token was put back, return it.
         if P.Pending_Token /= T_EOF then
            Token := P.Pending_Token;
            P.Pending_Token := T_EOF;
            return;
         end if;

         if P.Has_Pending_Char then
            C := P.Pending_Char;
         else
            --  Skip white spaces
            loop
               Stream.Read (Char => C);
               if C = Ada.Characters.Latin_1.LF then
                  P.Line_Number := P.Line_Number + 1;
               else
                  exit when C /= ' '
                    and C /= Ada.Characters.Latin_1.CR and C /= Ada.Characters.Latin_1.HT;
               end if;
            end loop;
         end if;
         P.Has_Pending_Char := False;

         --  See what we have and continue parsing.
         case C is
            --  Literal string using double quotes
            --  Collect up to the end of the string and put
            --  the result in the parser token result.
         when '"' =>
            Delete (P.Token, 1, Length (P.Token));
            loop
               Stream.Read (Char => C1);
               if C1 = '\' then
                  Stream.Read (Char => C1);
                  case C1 is
                     when '"' | '\' | '/' =>
                        C := C1;

                     when 'b' =>
                        C1 := Ada.Characters.Latin_1.BS;

                     when 'f' =>
                        C1 := Ada.Characters.Latin_1.VT;

                     when 'n' =>
                        C1 := Ada.Characters.Latin_1.LF;

                     when 'r' =>
                        C1 := Ada.Characters.Latin_1.CR;

                     when 't' =>
                        C1 := Ada.Characters.Latin_1.HT;

                     when 'u' =>
                        null;

                     when others =>
                        null;
                  end case;
               elsif C1 = C then
                  Token := T_STRING;
                  return;
               end if;
               Append (P.Token, C1);
            end loop;
            P.Error ("Missing '""' to terminate the string");
            return;

            --  Number
         when '-' | '0' .. '9' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when C not in '0' .. '9';
               Append (P.Token, C);
            end loop;
            if C = '.' then
               Append (P.Token, C);
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C = 'e' or C = 'E' then
               Append (P.Token, C);
               Stream.Read (Char => C);
               if C = '+' or C = '-' then
                  Append (P.Token, C);
                  Stream.Read (Char => C);
               end if;
               loop
                  Stream.Read (Char => C);
                  exit when C not in '0' .. '9';
                  Append (P.Token, C);
               end loop;
            end if;
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;
            Token := T_NUMBER;
            return;

            --  Parse a name composed of letters or digits.
         when 'a' .. 'z' | 'A' .. 'Z' =>
            Delete (P.Token, 1, Length (P.Token));
            Append (P.Token, C);
            loop
               Stream.Read (Char => C);
               exit when not (C in 'a' .. 'z' or C in 'A' .. 'Z'
                              or C in '0' .. '9' or C = '_');
               Append (P.Token, C);
            end loop;
            --  Putback the last character unless we can ignore it.
            if C /= ' ' and C /= Ada.Characters.Latin_1.HT then
               P.Has_Pending_Char := True;
               P.Pending_Char := C;
            end if;

            --  and empty eq false ge gt le lt ne not null true
            case Element (P.Token, 1) is
               when 'n' | 'N' =>
                  if P.Token = "null" then
                     Token := T_NULL;
                     return;
                  end if;

               when 'f' | 'F' =>
                  if P.Token = "false" then
                     Token := T_FALSE;
                     return;
                  end if;

               when 't' | 'T' =>
                  if P.Token = "true" then
                     Token := T_TRUE;
                     return;
                  end if;

               when others =>
                  null;
            end case;
            Token := T_UNKNOWN;
            return;

         when '{' =>
            Token := T_LEFT_BRACE;
            return;

         when '}' =>
            Token := T_RIGHT_BRACE;
            return;

         when '[' =>
            Token := T_LEFT_BRACKET;
            return;

         when ']' =>
            Token := T_RIGHT_BRACKET;
            return;

         when ':' =>
            Token := T_COLON;
            return;

         when ',' =>
            Token := T_COMMA;
            return;

         when others =>
            Token := T_UNKNOWN;
            return;
         end case;

      exception
         when Ada.IO_Exceptions.Data_Error =>
            Token := T_EOF;
            return;
      end Peek;

      --  ------------------------------
      --  Parse a number
      --  ------------------------------
      procedure Parse_Number (P      : in out Parser'Class;
                              Result : out Long_Long_Integer) is
         Value : Long_Long_Integer := 0;
         Num   : Long_Long_Integer;
         C     : Character;
      begin
         loop
            Stream.Read (Char => C);
            exit when C not in '0' .. '9';
            Num := Character'Pos (C) - Character'Pos ('0');
            Value := Value * 10 + Num;
         end loop;
         Result := Value;
      end Parse_Number;

   begin
      Parse (Handler);
   end Parse;

end Util.Serialize.IO.JSON;

Fix parsing of empty JSON arrays

Fix parsing of empty JSON arrays


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

   --  ------------------------------
   --  Set or update a variable in the `Wiki.Filters.Variable` filter.
   --  ------------------------------
   overriding
   procedure Expand (Plugin   : in out Variable_Plugin;
                     Document : in out Wiki.Documents.Document;
                     Params   : in out Wiki.Attributes.Attribute_List;
                     Context  : in Plugin_Context) is
      pragma Unreferenced (Plugin, Document);
   begin
      if Wiki.Attributes.Length (Params) >= 3 then
         declare
            First  : Wiki.Attributes.Cursor := Wiki.Attributes.First (Params);
            Second : Wiki.Attributes.Cursor;
         begin
            Wiki.Attributes.Next (First);
            Second := First;
            Wiki.Attributes.Next (Second);
            Wiki.Filters.Variables.Add_Variable (Context.Filters,
                                                 Wiki.Attributes.Get_Wide_Value (First),
                                                 Wiki.Attributes.Get_Wide_Value (Second));
         end;
      end if;
   end Expand;

end Wiki.Plugins.Variables;

Implement the variables plugin to set variables from wiki text


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

with ADO.Schemas;
with ADO.Statements;

package body ADO.Datasets is

   --  ------------------------------
   --  Execute the SQL query on the database session and populate the dataset.
   --  The column names are used to setup the dataset row bean definition.
   --  ------------------------------
   procedure List (Into    : in out Dataset;
                   Session : in out ADO.Sessions.Session'Class;
                   Query   : in ADO.Queries.Context'Class) is
      procedure Fill (Data : in out Util.Beans.Objects.Datasets.Object_Array);

      Stmt : ADO.Statements.Query_Statement := Session.Create_Statement (Query);

      procedure Fill (Data : in out Util.Beans.Objects.Datasets.Object_Array) is
         use ADO.Schemas;
      begin
         for I in Data'Range loop
            case Stmt.Get_Column_Type (I - 1) is
               --  Boolean column
               when T_BOOLEAN =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_Boolean (I - 1));

               when T_TINYINT | T_SMALLINT | T_INTEGER | T_LONG_INTEGER | T_YEAR =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_Integer (I - 1));

               when T_FLOAT | T_DOUBLE | T_DECIMAL =>
                  Data (I) := Util.Beans.Objects.Null_Object;

               when T_ENUM =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_String (I - 1));

               when T_TIME | T_DATE | T_DATE_TIME | T_TIMESTAMP =>
                  Data (I) := Util.Beans.Objects.Time.To_Object (Stmt.Get_Time (I - 1));

               when T_CHAR | T_VARCHAR =>
                  Data (I) := Util.Beans.Objects.To_Object (Stmt.Get_String (I - 1));

               when T_BLOB =>
                  Data (I) := Util.Beans.Objects.Null_Object;

               when T_SET | T_UNKNOWN | T_NULL =>
                  Data (I) := Util.Beans.Objects.Null_Object;

            end case;
         end loop;
      end Fill;

   begin
      Stmt.Execute;
      Into.Clear;
      if Stmt.Has_Elements then
         for I in 1 .. Stmt.Get_Column_Count loop
            Into.Add_Column (Stmt.Get_Column_Name (I - 1));
         end loop;
         while Stmt.Has_Elements loop
            Into.Append (Fill'Access);
            Stmt.Next;
         end loop;
      end if;
   end List;

end ADO.Datasets;

Implement the List operation to setup the database with the SQL query result


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

--  This package defines the procedures which scans the tree search paths for
--  a given Context and analyses the availible tree files

with Namet; use Namet;

package A4G.Contt.SD is

   First_Tree_File : Name_Id := First_Name_Id;
   Last_Tree_File  : Name_Id := First_Name_Id - 1;
   --  Indexes of the first and the last tree file candidates, which were
   --  found during the last scanning of the tree search path of some
   --  directory. Are set by Scan_Tree_Files below. These variables are
   --  undefinite
   --  SHOULD WE MOVE THESE VARIABLES IN THE BODY
   --  AND EVEN MORE - DO WE REALLY NEED THEM AT ALL??!!

   procedure Scan_Tree_Files_New (C : Context_Id);
   --  Stores the names of the tree files making up the Context C in the Tree
   --  table for C. Every tree file name is stored only once.
   --  In All_Trees Context mode it scans the tree search path, using the same
   --  approach for the tree files with the same name as GNAT does for source
   --  files in the source search path. In N_Trees mode it scans the Parametes
   --  string set when C was associated. In this case, if the name of the same
   --  tree file is given more than once, but in diffrent forms (for example
   --  ../my_dir/foo.ats and ../../my_home_dir/my_dir/foo.ats), all these
   --  different names of the same tree file will be stored in the tree table

   procedure Investigate_Trees_New (C : Context_Id);
   --  This procedure implements the second step of opening a Context. It uses
   --  the names of the tree files in the Context Tree Table. For every tree
   --  file, it reads it in and extracts some information about compilation
   --  units presented by this file. It also makes the consistency check.
   --  Checks which are made by this procedure depend on the context options
   --  which were set when C was associated.
   --
   --  Is this package the right location for this procedure???

   procedure Scan_Units_New;
   --  Scans the currently accessed tree which was readed in by the
   --  immediately preceding call to Read_and_Check_New. If a unit is "new"
   --  (that is, if it has not already been encountered during opening a
   --  Context), all the black-box information is computed and stored in the
   --  Context table. Otherwise (that is, if the unit is already "known")
   --  the consistency check is made.
   --
   --  When this procedure raises ASIS_Failed, it forms the Diagnosis string
   --  on befalf on Asis.Ada_Environments.Open

end A4G.Contt.SD;

Add the ASIS file $i

Add the ASIS file $i


Add the ASIS file $i

Add the ASIS file $i


-----------------------------------------------------------------------
--  components-widgets-gravatars -- Gravatar 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.Strings.Transforms;
with GNAT.MD5;

with ASF.Utils;
with ASF.Contexts.Writer;
package body ASF.Components.Widgets.Gravatars is

   IMAGE_ATTRIBUTE_NAMES : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Link (Email  : in String;
                      Secure : in Boolean := False) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      if Secure then
         return "https://secure.gravatar.com/avatar/" & C;
      else
         return "http://www.gravatar.com/avatar/" & C;
      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 UIGravatar;
                           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 ("img");
         UI.Render_Attributes (Context, IMAGE_ATTRIBUTE_NAMES, Writer);
         declare
            Email   : constant String := UI.Get_Attribute ("email", Context, "");
            Size    : constant Natural := UI.Get_Attribute ("size", Context, 60);
            Default : constant String := UI.Get_Attribute ("default", Context, "identicon");
            Secure  : constant Boolean := UI.Get_Attribute ("secure", Context, False);
            D       : constant String := Util.Strings.Image (Size);
         begin
            Writer.Write_Attribute ("width", D);
            Writer.Write_Attribute ("height", D);
            Writer.Write_Attribute ("src", Get_Link (Email, Secure)
                                    & "?d=" & Default & "&s=" & D);
         end;
         Writer.End_Element ("img");
      end if;
   end Encode_Begin;

begin
   Utils.Set_Text_Attributes (IMAGE_ATTRIBUTE_NAMES);
end ASF.Components.Widgets.Gravatars;

Implement the UI gravatar component

Implement the UI gravatar component


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

with Util.Tests;

package ASF.Navigations.Tests is

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

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

   --  Initialize the test application
   overriding
   procedure Set_Up (T : in out Test);

   --  Test a form navigation with an exact match (view, outcome, action).
   procedure Test_Exact_Navigation (T : in out Test);

   --  Test a form navigation with a partial match (view, outcome).
   procedure Test_Partial_Navigation (T : in out Test);

   --  Test a form navigation with a exception match (view, outcome).
   procedure Test_Exception_Navigation (T : in out Test);

   --  Check the navigation for an URI and expect the result to match the regular expression.
   procedure Check_Navigation (T     : in out Test;
                               Name  : in String;
                               Match : in String;
                               Raise_Flag : in Boolean := False);

end ASF.Navigations.Tests;

Add navigation rule unit test

Add navigation rule unit test


-----------------------------------------------------------------------
--  druss-commands-devices -- Print information about the devices
--  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.Properties;
with Bbox.API;
with Druss.Gateways;
package body Druss.Commands.Devices is

   --  ------------------------------
   --  Execute the wifi 'status' command to print the Wifi current status.
   --  ------------------------------
   procedure Do_List (Command   : in Command_Type;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Command);

      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;

      procedure Box_Status (Gateway : in out Druss.Gateways.Gateway_Type) is

         procedure Print_Device (Manager : in Util.Properties.Manager;
                                 Name    : in String) is
            Link : constant String := Manager.Get (Name & ".link", "");
            Kind : constant String := Manager.Get (Name & ".devicetype", "");
         begin
            if Manager.Get (Name & ".active", "") = "0" then
               return;
            end if;
            Console.Start_Row;
            Console.Print_Field (F_BBOX_IP_ADDR, Gateway.Ip);
            Console.Print_Field (F_IP_ADDR, Manager.Get (Name & ".ipaddress", ""));
            Console.Print_Field (F_ETHERNET, Manager.Get (Name & ".macaddress", ""));
            Console.Print_Field (F_HOSTNAME, Manager.Get (Name & ".hostname", ""));
            Console.Print_Field (F_ACTIVE, Manager.Get (Name & ".active", ""));
            Console.Print_Field (F_DEVTYPE, (if Kind = "STB" then "STB" else ""));
            if Link = "Ethernet" then
               Console.Print_Field (F_LINK, Link & " port "
                                    & Manager.Get (Name & ".ethernet.logicalport", ""));
            else
               Console.Print_Field (F_LINK, Link & " RSSI "
                                    & Manager.Get (Name & ".wireless.rssi0", ""));
            end if;
            Console.End_Row;
         end Print_Device;

      begin
         Gateway.Refresh;

         Bbox.API.Iterate (Gateway.Hosts, "hosts.list", Print_Device'Access);
      end Box_Status;

   begin
      Console.Start_Title;
      Console.Print_Title (F_BBOX_IP_ADDR, "Bbox IP", 16);
      Console.Print_Title (F_IP_ADDR, "Device IP", 16);
      Console.Print_Title (F_ETHERNET, "Ethernet", 20);
      Console.Print_Title (F_HOSTNAME, "Hostname", 28);
      Console.Print_Title (F_DEVTYPE, "Type", 6);
      --  Console.Print_Title (F_ACTIVE, "Active", 8);
      Console.Print_Title (F_LINK, "Link", 18);
      Console.End_Title;
      Druss.Gateways.Iterate (Context.Gateways, Gateways.ITER_ENABLE, Box_Status'Access);
   end Do_List;

   --  Execute a status command to report information about the Bbox.
   overriding
   procedure Execute (Command   : in Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is
      pragma Unreferenced (Name);
   begin
      Command.Do_List (Args, Context);
   end Execute;

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in Command_Type;
                   Context   : in out Context_Type) is
      pragma Unreferenced (Command);
      Console : constant Druss.Commands.Consoles.Console_Access := Context.Console;
   begin
      Console.Notice (N_HELP, "devices: Print information about the devices");
      Console.Notice (N_HELP, "Usage: devices [options]");
      Console.Notice (N_HELP, "");
   end Help;

end Druss.Commands.Devices;

Implement the device command to list the devices and give some information


-----------------------------------------------------------------------
--  Faces Context Tests - Unit tests for ASF.Contexts.Faces
--  Copyright (C) 2010, 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Calendar;
with Ada.Calendar.Formatting;
with Util.Beans.Objects.Time;
with Util.Test_Caller;
with ASF.Tests;
with ASF.Components.Html.Text;
with ASF.Converters.Dates;
package body ASF.Converters.Tests is

   use Util.Tests;
   use ASF.Converters.Dates;

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

   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String);

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Short)",
                       Test_Date_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Medium)",
                       Test_Date_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Long)",
                       Test_Date_Long_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Date, Full)",
                       Test_Date_Full_Converter'Access);

      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Short)",
                       Test_Time_Short_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Medium)",
                       Test_Time_Medium_Converter'Access);
      Caller.Add_Test (Suite, "Test ASF.Converters.Dates.To_String (Time, Long)",
                       Test_Time_Long_Converter'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test getting an attribute from the faces context.
   --  ------------------------------
   procedure Test_Date_Conversion (T          : in out Test;
                                   Date_Style : in Dates.Style_Type;
                                   Time_Style : in Dates.Style_Type;
                                   Expect     : in String) is
      Ctx   : aliased ASF.Contexts.Faces.Faces_Context;
      UI    : ASF.Components.Html.Text.UIOutput;
      C     : ASF.Converters.Dates.Date_Converter_Access;
      D     : constant Ada.Calendar.Time := Ada.Calendar.Formatting.Time_Of (2011, 11, 19,
                                                                             3, 4, 5);
   begin
      T.Setup (Ctx);
      ASF.Contexts.Faces.Set_Current (Ctx'Unchecked_Access, ASF.Tests.Get_Application.all'Access);

      if Date_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.TIME,
                                                          Locale  => "en",
                                                          Pattern => "");
      elsif Time_Style = Dates.DEFAULT then
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.DATE,
                                                          Locale  => "en",
                                                          Pattern => "");
      else
         C := ASF.Converters.Dates.Create_Date_Converter (Date    => Date_Style,
                                                          Time    => Time_Style,
                                                          Format  => ASF.Converters.Dates.BOTH,
                                                          Locale  => "en",
                                                          Pattern => "");
      end if;
      UI.Set_Converter (C.all'Access);
      declare
         R : constant String := C.To_String (Ctx, UI, Util.Beans.Objects.Time.To_Object (D));
      begin
         Util.Tests.Assert_Equals (T, Expect, R, "Invalid date conversion");
      end;
   end Test_Date_Conversion;

   --  ------------------------------
   --  Test the date short converter.
   --  ------------------------------
   procedure Test_Date_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.SHORT, ASF.Converters.Dates.DEFAULT,
                            "19/11/2011");
   end Test_Date_Short_Converter;

   --  ------------------------------
   --  Test the date medium converter.
   --  ------------------------------
   procedure Test_Date_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.MEDIUM, ASF.Converters.Dates.DEFAULT,
                            "Nov 19, 2011");
   end Test_Date_Medium_Converter;

   --  ------------------------------
   --  Test the date long converter.
   --  ------------------------------
   procedure Test_Date_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.LONG, ASF.Converters.Dates.DEFAULT,
                            "November 19, 2011");
   end Test_Date_Long_Converter;

   --  ------------------------------
   --  Test the date full converter.
   --  ------------------------------
   procedure Test_Date_Full_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.FULL, ASF.Converters.Dates.DEFAULT,
                            "Saturday, November 19, 2011");
   end Test_Date_Full_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Short_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.SHORT,
                            "03:04");
   end Test_Time_Short_Converter;

   --  ------------------------------
   --  Test the time short converter.
   --  ------------------------------
   procedure Test_Time_Medium_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.MEDIUM,
                            "03:04");
   end Test_Time_Medium_Converter;

   --  ------------------------------
   --  Test the time long converter.
   --  ------------------------------
   procedure Test_Time_Long_Converter (T : in out Test) is
   begin
      Test_Date_Conversion (T, ASF.Converters.Dates.DEFAULT, ASF.Converters.Dates.LONG,
                            "03:04:05");
   end Test_Time_Long_Converter;

end ASF.Converters.Tests;

Implement some unit tests for date and time conversion


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

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings;             use Ada.Strings;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;

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

with A4G.A_Debug;             use A4G.A_Debug;
with A4G.A_Opt;               use A4G.A_Opt;
with A4G.Contt;               use A4G.Contt;
with A4G.Defaults;
with A4G.Vcheck;              use A4G.Vcheck;

with A4G.A_Osint;             use A4G.A_Osint;

with Gnatvsn;
with Opt;

package body Asis.Implementation is

   Package_Name : constant String := "Asis.Implementation.";

   ----------------------
   -- Asis_Implementor --
   ----------------------

   function ASIS_Implementor return Wide_String is
   begin
      return "AdaCore (http://www.adacore.com)";
   end ASIS_Implementor;

   ----------------------------------
   -- ASIS_Implementor_Information --
   ----------------------------------

   function ASIS_Implementor_Information return Wide_String is
   begin
      return
        "Copyright (C) 1995-"                 &
        To_Wide_String (Gnatvsn.Current_Year) &
        ", Free Software Foundation";
   end ASIS_Implementor_Information;

   ------------------------------
   -- ASIS_Implementor_Version --
   ------------------------------

   function ASIS_Implementor_Version return Wide_String is
      GNAT_Version   : constant String   := Gnatvsn.Gnat_Version_String;
      First_Idx      : constant Positive := GNAT_Version'First;
      Last_Idx       :          Positive := GNAT_Version'Last;
      Minus_Detected : Boolean           := False;
   begin

      for J in reverse GNAT_Version'Range loop

         if GNAT_Version (J) = '-' then
            Last_Idx       := J - 1;
            Minus_Detected := True;
            exit;
         end if;

      end loop;

      if Minus_Detected then
         return ASIS_Version & " for GNAT " &
            To_Wide_String (GNAT_Version (First_Idx .. Last_Idx)) & ")";
      else
         return ASIS_Version & " for GNAT " &
            To_Wide_String (GNAT_Version (First_Idx .. Last_Idx));
      end if;

   end ASIS_Implementor_Version;

   ------------------
   -- ASIS_Version --
   ------------------

   function ASIS_Version return Wide_String is
   begin
      return "ASIS 2.0.R";
   end ASIS_Version;

   ---------------
   -- Diagnosis --
   ---------------

   function Diagnosis return Wide_String is
   begin
      --  The ASIS Diagnosis string uses only the first 256 values of
      --  Wide_Character type
      return To_Wide_String (Diagnosis_Buffer (1 .. Diagnosis_Len));
   end Diagnosis;

   --------------
   -- Finalize --
   --------------

   procedure Finalize (Parameters : Wide_String := "") is
      S_Parameters : constant String := Trim (To_String (Parameters), Both);
      --  all the valid actuals for Parametes should contain  only
      --  characters from the first 256 values of Wide_Character type
   begin

      if not A4G.A_Opt.Is_Initialized then
         return;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Print_Context_Info;
      end if;

      if S_Parameters'Length > 0 then
         Process_Finalization_Parameters (S_Parameters);
      end if;

      A4G.Contt.Finalize;
      A4G.A_Opt.Set_Off;
      A4G.A_Debug.Set_Off;

      A4G.A_Opt.Is_Initialized := False;

   exception
      when ASIS_Failed =>

         A4G.A_Opt.Set_Off;
         A4G.A_Debug.Set_Off;

         A4G.A_Opt.Is_Initialized := False;

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

         raise;

      when Ex : others =>

         A4G.A_Opt.Set_Off;
         A4G.A_Debug.Set_Off;

         A4G.A_Opt.Is_Initialized := False;

         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Finalize",
            Ex          => Ex);
   end Finalize;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Parameters : Wide_String := "") is
      S_Parameters : constant String := Trim (To_String (Parameters), Both);
      --  all the valid actuals for Parametes should contain  only
      --  characters from the first 256 values of Wide_Character type
   begin
      if A4G.A_Opt.Is_Initialized then
         return;
      end if;

      if not A4G.A_Opt.Was_Initialized_At_Least_Once then
         Opt.Maximum_File_Name_Length := Get_Max_File_Name_Length;
         A4G.A_Opt.Was_Initialized_At_Least_Once := True;
      end if;

      if S_Parameters'Length > 0 then
         Process_Initialization_Parameters (S_Parameters);
      end if;

      A4G.Contt.Initialize;
      A4G.Defaults.Initialize;
      A4G.A_Opt.Is_Initialized := True;

   exception
      when ASIS_Failed =>

         A4G.A_Opt.Set_Off;
         A4G.A_Debug.Set_Off;

         A4G.A_Opt.Is_Initialized := False;

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

         raise;

      when Ex : others =>

         A4G.A_Opt.Set_Off;
         A4G.A_Debug.Set_Off;

         A4G.A_Opt.Is_Initialized := False;

         Report_ASIS_Bug
           (Query_Name  => Package_Name & "Initialize",
            Ex          => Ex);
   end Initialize;

   ------------------
   -- Is_Finalized --
   ------------------

   function Is_Finalized return Boolean is
   begin
      return not A4G.A_Opt.Is_Initialized;
   end Is_Finalized;

   --------------------
   -- Is_Initialized --
   --------------------

   function Is_Initialized return Boolean  is
   begin
      return A4G.A_Opt.Is_Initialized;
   end Is_Initialized;

   ----------------
   -- Set_Status --
   ----------------

   procedure Set_Status
     (Status    : Asis.Errors.Error_Kinds := Asis.Errors.Not_An_Error;
      Diagnosis : Wide_String             := "")
   is
   begin
      A4G.Vcheck.Set_Error_Status (Status    => Status,
                                   Diagnosis => To_String (Diagnosis));
   end Set_Status;

   ------------
   -- Status --
   ------------

   function Status return Asis.Errors.Error_Kinds is
   begin
      return Status_Indicator;
   end Status;

end Asis.Implementation;

Add the ASIS file $i

Add the ASIS file $i


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

with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with ASF.Applications.Main;

with Security.Contexts;
with Security.Policies.URLs;
package body ASF.Security.Filters.OAuth is

   use Ada.Strings.Unbounded;
   use Servers;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Filters.OAuth");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config) is
      use ASF.Applications;

      Context : constant Servlets.Servlet_Registry_Access := Servlets.Get_Servlet_Context (Config);
   begin
      if Context.all in Main.Application'Class then
         Server.Set_Permission_Manager (Main.Application'Class (Context.all).Get_Security_Manager);
      end if;
   end Initialize;

   --  ------------------------------
   --  Set the permission manager that must be used to verify the permission.
   --  ------------------------------
   procedure Set_Permission_Manager (Filter  : in out Auth_Filter;
                                     Manager : in Policies.Policy_Manager_Access) is
   begin
      Filter.Manager := Manager;
   end Set_Permission_Manager;

   function Get_Access_Token (Request : in ASF.Requests.Request'Class) return String is
      Header : constant String := Request.Get_Header (AUTHORIZATION_HEADER_NAME);
   begin
      if Header'Length > 0 then
         return Header;
      end if;
      return Header;
   end Get_Access_Token;

   --  ------------------------------
   --  Filter the request to make sure the user is authenticated.
   --  Invokes the Do_Login procedure if there is no user.
   --  If a permission manager is defined, check that the user has the permission
   --  to view the page.  Invokes the Do_Deny procedure if the permission
   --  is denied.
   --  ------------------------------
   procedure Do_Filter (F        : in Auth_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain) is
      use Ada.Strings.Unbounded;
      use Policies.URLs;
      use type Policies.Policy_Manager_Access;

      Servlet : constant String := Request.Get_Servlet_Path;
      URL     : constant String := Servlet & Request.Get_Path_Info;
   begin
      if F.Realm = null then
         Log.Error ("Deny access on {0} due to missing realm", URL);
         Auth_Filter'Class (F).Do_Deny (Request, Response);
         return;
      end if;
      declare
         Bearer  : constant String := Get_Access_Token (Request);
         Auth    : Principal_Access;
         Grant   : Servers.Grant_Type;
         Context : aliased Contexts.Security_Context;
      begin
         if Bearer'Length = 0 then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Login (Request, Response);
            return;
         end if;
         F.Realm.Authenticate (Bearer, Grant);
         if Grant.Status /= Valid_Grant then
            Log.Info ("Ask authentication on {0} due to missing access token", URL);
            Auth_Filter'Class (F).Do_Deny (Request, Response);
            return;
         end if;

         --  Request is authorized, proceed to the next filter.
         ASF.Servlets.Do_Filter (Chain    => Chain,
                                 Request  => Request,
                                 Response => Response);
      end;
   end Do_Filter;

   --  ------------------------------
   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   --  ------------------------------
   procedure Do_Login (F        : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (F, Request);
   begin
      Response.Send_Error (ASF.Responses.SC_UNAUTHORIZED);
   end Do_Login;

   --  ------------------------------
   --  Display the forbidden access page.  This procedure is called when the user is not
   --  authorized to see the page.  The default implementation returns the SC_FORBIDDEN error.
   --  ------------------------------
   procedure Do_Deny (F        : in Auth_Filter;
                      Request  : in out ASF.Requests.Request'Class;
                      Response : in out ASF.Responses.Response'Class) is
      pragma Unreferenced (Request);
   begin
      Response.Add_Header (WWW_AUTHENTICATE_HEADER_NAME,
                           "Bearer realm=""" & To_String (F.Realm_URL)
                           & """, error=""invalid_token""");
      Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
   end Do_Deny;

end ASF.Security.Filters.OAuth;

Implement the Auth_Filter operations with verification of the access_token for the OAuth API call operation


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

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log     : constant Logger := Create ("log", "samples/log4j.properties");

   Factory : Util.Properties.Bundles.Loader;

   Bundle  : Util.Properties.Bundles.Manager;

   Locale  : Unbounded_String := To_Unbounded_String ("en");
   Result  : Ada.Strings.Unbounded.Unbounded_String;
begin
   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            Log.Info ("Usage: date -l locale format");
            return;
      end case;
   end loop;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Util.Dates.Formats.Format (Pattern => Pattern,
                                    Date    => Ada.Calendar.Clock,
                                    Bundle  => Bundle,
                                    Into    => Result);
         Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Result));
      end;
   end loop;
end Date;

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

with Util.Log.Loggers;
with Util.Dates.Formats;
with Util.Properties.Bundles;
procedure Date is

   use type Ada.Calendar.Time;
   use Util.Log.Loggers;
   use Ada.Strings.Unbounded;
   use Util.Properties.Bundles;
   use GNAT.Command_Line;

   Log     : constant Logger := Create ("log", "samples/log4j.properties");

   Factory : Util.Properties.Bundles.Loader;

   Bundle  : Util.Properties.Bundles.Manager;

   Locale  : Unbounded_String := To_Unbounded_String ("en");
   Date    : Ada.Calendar.Time := Ada.Calendar.Clock;

begin
   --  Load the bundles from the current directory
   Initialize (Factory, "samples/;bundles");

   loop
      case Getopt ("h l: locale: help") is
         when ASCII.NUL =>
            exit;

         when 'l' =>
            Locale := To_Unbounded_String (Parameter);

         when others =>
            Log.Info ("Usage: date -l locale format");
            return;
      end case;
   end loop;
   begin
      Load_Bundle (Factory, "dates", To_String (Locale), Bundle);

   exception
      when NO_BUNDLE =>
         Log.Error ("There is no bundle: {0}", "dates");
   end;
   loop
      declare
         Pattern : constant String := Get_Argument;
      begin
         exit when Pattern = "";

         Ada.Text_IO.Put_Line (Util.Dates.Formats.Format (Pattern => Pattern,
                                                          Date    => Date,
                                                          Bundle  => Bundle));
      end;
   end loop;
end Date;

Update the date example so that -l option works


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

with Util.Test_Caller;
with Util.Files;
package body Util.Properties.Form.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Properties.Form.Parse_Form",
                       Test_Parse_Form'Access);
   end Add_Tests;

   --  Test loading a JSON file into a properties object.
   procedure Test_Parse_Form (T : in out Test) is
      procedure Check (Name : in String;
                       Value : in String);

      P    : Util.Properties.Manager;

      procedure Check (Name : in String;
                       Value : in String) is
      begin
         T.Assert (P.Exists (Name), "Missing property: " & Name);
         Util.Tests.Assert_Equals (T, Value, String '(P.Get (Name)),
                                   "Invalid property: " & Name);
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/files/test-1.form");
      S    : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Util.Files.Read_File (Path, S);
      Util.Properties.Form.Parse_Form (P, Ada.Strings.Unbounded.To_String (S));

      Check ("access_token", "97356");
      Check ("token_type", "bearer");
      Check ("refresh_token_expires_in", "15724800");
      Check ("refresh_token", "r1.714b6");
      Check ("scope", "");
      Check ("scope", "");
   end Test_Parse_Form;

end Util.Properties.Form.Tests;

Implement new test for Parse_Form and register it for execution


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

package body Babel.Base.Users.Tests is

   use type Util.Strings.Name_Access;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Base.Users.Find",
                       Test_Find'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Find (T : in out Test) is
      Db   : Babel.Base.Users.Database;
      User : User_Type;
   begin
      User := Db.Find (0, 0);
      T.Assert (User.Name /= null, "User uid=0 was not found");
      T.Assert (User.Group /= null, "User gid=0 was not found");
      Util.Tests.Assert_Equals (T, "root", User.Name.all, "Invalid root user name");
      Util.Tests.Assert_Equals (T, "root", User.Group.all, "Invalid root group name");
   end Test_Find;

end Babel.Base.Users.Tests;

Implement a simple unit test for the Find operation