-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 2012, 2015, 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 GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name, Args);

      Doc  : Gen.Artifacts.Docs.Artifact;
      M    : Gen.Model.Packages.Model_Definition;
      Arg1 : constant String := Get_Argument;
      Arg2 : constant String := Get_Argument;
      Fmt  : Gen.Artifacts.Docs.Doc_Format := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      if Arg1'Length = 0 then
         Generator.Error ("Missing target directory");
         return;
      elsif Arg1 (Arg1'First) /= '-' then
         if Arg2'Length /= 0 then
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         --  Setup the target directory where the distribution is created.
         Generator.Set_Result_Directory (Arg1);
      else
         if Arg1 = "-markdown" then
            Fmt := Gen.Artifacts.Docs.DOC_MARKDOWN;
         elsif Arg1 = "-google" then
            Fmt := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
         else
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         if Arg2'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Arg2);
      end if;
      Doc.Set_Format (Fmt);
      Doc.Prepare (M, Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc [-markdown|-google] target-dir");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 2012, 2015, 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 GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   overriding
   procedure Execute (Cmd       : in Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Name, Args);

      Doc    : Gen.Artifacts.Docs.Artifact;
      M      : Gen.Model.Packages.Model_Definition;
      Arg1   : constant String := Get_Argument;
      Arg2   : constant String := Get_Argument;
      Footer : Boolean := True;
      Fmt    : Gen.Artifacts.Docs.Doc_Format := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      if Arg1'Length = 0 then
         Generator.Error ("Missing target directory");
         return;
      elsif Arg1 (Arg1'First) /= '-' then
         if Arg2'Length /= 0 then
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         --  Setup the target directory where the distribution is created.
         Generator.Set_Result_Directory (Arg1);
      else
         if Arg1 = "-markdown" then
            Fmt := Gen.Artifacts.Docs.DOC_MARKDOWN;
         elsif Arg1 = "-google" then
            Fmt := Gen.Artifacts.Docs.DOC_WIKI_GOOGLE;
         elsif Arg1 = "-pandoc" then
            Fmt := Gen.Artifacts.Docs.DOC_MARKDOWN;
            Footer := False;
         else
            Generator.Error ("Invalid markup option " & Arg1);
            return;
         end if;
         if Arg2'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Arg2);
      end if;
      Doc.Set_Format (Fmt, Footer);
      Doc.Prepare (M, Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   overriding
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc [-markdown|-google|-pandoc] target-dir");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

Add the -pandoc option to generate documentation without footer link


------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Encodings is

   --------------------------
   -- Hexadecimal Decoding --
   --------------------------

   function Is_Hex_Digit (Value : in Octet) return Boolean is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return True;
         when Lower_A .. Lower_F => return True;
         when Upper_A .. Upper_F => return True;
         when others             => return False;
      end case;
   end Is_Hex_Digit;

   function Decode_Hex (Value : in Octet) return Octet is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return Value - Digit_0;
         when Lower_A .. Lower_F => return Value - Lower_A + 10;
         when Upper_A .. Upper_F => return Value - Upper_A + 10;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Hex;

   function Decode_Hex (High, Low : in Octet) return Octet is
   begin
      return Decode_Hex (High) * 16 + Decode_Hex (Low);
   end Decode_Hex;

   function Decode_Hex (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Hex_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      Length := (Length + 1) / 2;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Offset := Result'First;
            High : Octet := 0;
            Has_High : Boolean := False;
         begin
            for I in Data'Range loop
               if Is_Hex_Digit (Data (I)) then
                  if Has_High then
                     Result (O) := Decode_Hex (High, Data (I));
                     O := O + 1;
                     High := 0;
                     Has_High := False;
                  else
                     High := Data (I);
                     Has_High := True;
                  end if;
               end if;
            end loop;
            if Has_High then
               Result (O) := Decode_Hex (High, Digit_0);
               O := O + 1;
            end if;
            pragma Assert (O - 1 = Result'Last);
         end;
      end return;
   end Decode_Hex;

   --------------------------
   -- Hexadecimal Encoding --
   --------------------------

   function Encode_Hex (Value : in Octet; Casing : in Hex_Casing)
     return Octet is
   begin
      case Value is
         when 0 .. 9 =>
            return Digit_0 + Value;
         when 10 .. 15 =>
            case Casing is
               when Upper => return Upper_A + Value - 10;
               when Lower => return Lower_A + Value - 10;
            end case;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Hex;

   procedure Encode_Hex
     (Value : in Octet;
      Casing : in Hex_Casing;
      High, Low : out Octet) is
   begin
      High := Encode_Hex (Value / 2**4 mod 2**4, Casing);
      Low  := Encode_Hex (Value mod 2**4, Casing);
   end Encode_Hex;

   function Encode_Hex (Data : in Atom; Casing : in Hex_Casing) return Atom is
      Result : Atom (0 .. Data'Length * 2 - 1);
      Cursor : Offset := Result'First;
   begin
      for I in Data'Range loop
         Encode_Hex (Data (I), Casing, Result (Cursor), Result (Cursor + 1));
         Cursor := Cursor + 2;
      end loop;
      pragma Assert (Cursor = Result'Last + 1);

      return Result;
   end Encode_Hex;

   ----------------------
   -- Base-64 Decoding --
   ----------------------

   function Is_Base64_Digit (Value : in Octet) return Boolean is
   begin
      return Value in Digit_0 .. Digit_9
        or Value in Lower_A .. Lower_Z
        or Value in Upper_A .. Upper_Z
        or Value = Plus
        or Value = Slash;
   end Is_Base64_Digit;

   function Decode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when Upper_A .. Upper_Z => return Value - Upper_A + 0;
         when Lower_A .. Lower_Z => return Value - Lower_A + 26;
         when Digit_0 .. Digit_9 => return Value - Digit_0 + 52;
         when Plus               => return 62;
         when Slash              => return 63;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Base64;

   function Decode_Base64 (A, B : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
   begin
      return (0 => VA * 2**2 + VB / 2**4);
   end Decode_Base64;

   function Decode_Base64 (A, B, C : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2);
   end Decode_Base64;

   function Decode_Base64 (A, B, C, D : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
      VD : constant Octet := Decode_Base64 (D);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2,
              2 => VC * 2**6 + VD);
   end Decode_Base64;

   function Decode_Base64 (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Base64_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      declare
         Chunks : constant Count := Length / 4;
         Remains : constant Count := Length mod 4;
      begin
         if Remains >= 2 then
            Length := Chunks * 3 + Remains - 1;
         else
            Length := Chunks * 3;
         end if;
      end;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Count := Result'First;
            Buffer : Atom (0 .. 3);
            Accumulated : Count := 0;
         begin
            for I in Data'Range loop
               if Is_Base64_Digit (Data (I)) then
                  Buffer (Accumulated) := Data (I);
                  Accumulated := Accumulated + 1;
                  if Accumulated = 4 then
                     Result (O .. O + 2) := Decode_Base64 (Buffer (0),
                                                           Buffer (1),
                                                           Buffer (2),
                                                           Buffer (3));
                     O := O + 3;
                     Accumulated := 0;
                  end if;
               end if;
            end loop;

            if Accumulated = 2 then
               Result (O .. O) := Decode_Base64 (Buffer (0), Buffer (1));
               O := O + 1;
            elsif Accumulated = 3 then
               Result (O .. O + 1) := Decode_Base64 (Buffer (0),
                                                     Buffer (1),
                                                     Buffer (2));
               O := O + 2;
            end if;

            pragma Assert (O = Length);
         end;
      end return;
   end Decode_Base64;

   ----------------------
   -- Base-64 Encoding --
   ----------------------

   function Encode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when 0 .. 25 =>
            return Upper_A + Value;
         when 26 .. 51 =>
            return Lower_A + Value - 26;
         when 52 .. 61 =>
            return Digit_0 + Value - 52;
         when 62 =>
            return Plus;
         when 63 =>
            return Slash;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 (A * 2**4 mod 2**6);
      Output (Output'First + 2) := Base64_Filler;
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A, B : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 (B * 2**2 mod 2**6);
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A, B, C : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 ((B * 2**2 + C / 2**6)
                                                  mod 2**6);
      Output (Output'First + 3) := Encode_Base64 (C mod 2**6);
   end Encode_Base64;

   function Encode_Base64 (Data : in Atom) return Atom is
      Chunks : constant Count := (Data'Length + 2) / 3;
      Result : Atom (0 .. Chunks * 4 - 1);
      Cursor : Offset := Result'First;
      I      : Offset := Data'First;
   begin
      while I in Data'Range loop
         if I + 2 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1),
               Data (I + 2));
            I := I + 3;
         elsif I + 1 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1));
            I := I + 2;
         else
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I));
            I := I + 1;
         end if;
         Cursor := Cursor + 4;
      end loop;

      return Result;
   end Encode_Base64;

   ---------------------------------
   -- Base-64 with other charsets --
   ---------------------------------

   function Decode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Recoded : Atom := Data;
   begin
      for I in Recoded'Range loop
         if Recoded (I) = Digit_62 then
            Recoded (I) := Plus;
         elsif Recoded (I) = Digit_63 then
            Recoded (I) := Slash;
         end if;
      end loop;

      return Decode_Base64 (Recoded);
   end Decode_Base64;

   function Encode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
      Last : Count := Result'Last;
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            for J in I + 1 .. Result'Last loop
               pragma Assert (Result (J) = Base64_Filler);
            end loop;
            Last := I - 1;
            exit;
         end if;
      end loop;

      return Result (Result'First .. Last);
   end Encode_Base64;

   function Encode_Base64
     (Data : in Atom;
      Digit_62, Digit_63, Padding : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            Result (I) := Padding;
         end if;
      end loop;

      return Result;
   end Encode_Base64;

end Natools.S_Expressions.Encodings;

------------------------------------------------------------------------------
-- Copyright (c) 2013, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Encodings is

   --------------------------
   -- Hexadecimal Decoding --
   --------------------------

   function Is_Hex_Digit (Value : in Octet) return Boolean is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return True;
         when Lower_A .. Lower_F => return True;
         when Upper_A .. Upper_F => return True;
         when others             => return False;
      end case;
   end Is_Hex_Digit;

   function Decode_Hex (Value : in Octet) return Octet is
   begin
      case Value is
         when Digit_0 .. Digit_9 => return Value - Digit_0;
         when Lower_A .. Lower_F => return Value - Lower_A + 10;
         when Upper_A .. Upper_F => return Value - Upper_A + 10;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Hex;

   function Decode_Hex (High, Low : in Octet) return Octet is
   begin
      return Decode_Hex (High) * 16 + Decode_Hex (Low);
   end Decode_Hex;

   function Decode_Hex (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Hex_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      Length := (Length + 1) / 2;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Offset := Result'First;
            High : Octet := 0;
            Has_High : Boolean := False;
         begin
            for I in Data'Range loop
               if Is_Hex_Digit (Data (I)) then
                  if Has_High then
                     Result (O) := Decode_Hex (High, Data (I));
                     O := O + 1;
                     High := 0;
                     Has_High := False;
                  else
                     High := Data (I);
                     Has_High := True;
                  end if;
               end if;
            end loop;
            if Has_High then
               Result (O) := Decode_Hex (High, Digit_0);
               O := O + 1;
            end if;
            pragma Assert (O - 1 = Result'Last);
         end;
      end return;
   end Decode_Hex;

   --------------------------
   -- Hexadecimal Encoding --
   --------------------------

   function Encode_Hex (Value : in Octet; Casing : in Hex_Casing)
     return Octet is
   begin
      case Value is
         when 0 .. 9 =>
            return Digit_0 + Value;
         when 10 .. 15 =>
            case Casing is
               when Upper => return Upper_A + Value - 10;
               when Lower => return Lower_A + Value - 10;
            end case;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Hex;

   procedure Encode_Hex
     (Value : in Octet;
      Casing : in Hex_Casing;
      High, Low : out Octet) is
   begin
      High := Encode_Hex (Value / 2**4 mod 2**4, Casing);
      Low  := Encode_Hex (Value mod 2**4, Casing);
   end Encode_Hex;

   function Encode_Hex (Data : in Atom; Casing : in Hex_Casing) return Atom is
      Result : Atom (0 .. Data'Length * 2 - 1);
      Cursor : Offset := Result'First;
   begin
      for I in Data'Range loop
         Encode_Hex (Data (I), Casing, Result (Cursor), Result (Cursor + 1));
         Cursor := Cursor + 2;
      end loop;
      pragma Assert (Cursor = Result'Last + 1);

      return Result;
   end Encode_Hex;

   ----------------------
   -- Base-64 Decoding --
   ----------------------

   function Is_Base64_Digit (Value : in Octet) return Boolean is
   begin
      return Value in Digit_0 .. Digit_9
        or Value in Lower_A .. Lower_Z
        or Value in Upper_A .. Upper_Z
        or Value = Plus
        or Value = Slash;
   end Is_Base64_Digit;

   function Decode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when Upper_A .. Upper_Z => return Value - Upper_A + 0;
         when Lower_A .. Lower_Z => return Value - Lower_A + 26;
         when Digit_0 .. Digit_9 => return Value - Digit_0 + 52;
         when Plus               => return 62;
         when Slash              => return 63;
         when others             => raise Constraint_Error;
      end case;
   end Decode_Base64;

   function Decode_Base64 (A, B : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
   begin
      return (0 => VA * 2**2 + VB / 2**4);
   end Decode_Base64;

   function Decode_Base64 (A, B, C : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2);
   end Decode_Base64;

   function Decode_Base64 (A, B, C, D : in Octet) return Atom is
      VA : constant Octet := Decode_Base64 (A);
      VB : constant Octet := Decode_Base64 (B);
      VC : constant Octet := Decode_Base64 (C);
      VD : constant Octet := Decode_Base64 (D);
   begin
      return (0 => VA * 2**2 + VB / 2**4,
              1 => VB * 2**4 + VC / 2**2,
              2 => VC * 2**6 + VD);
   end Decode_Base64;

   function Decode_Base64 (Data : in Atom) return Atom is
      Length : Count := 0;
   begin
      for I in Data'Range loop
         if Is_Base64_Digit (Data (I)) then
            Length := Length + 1;
         end if;
      end loop;

      declare
         Chunks : constant Count := Length / 4;
         Remains : constant Count := Length mod 4;
      begin
         if Remains >= 2 then
            Length := Chunks * 3 + Remains - 1;
         else
            Length := Chunks * 3;
         end if;
      end;

      return Result : Atom (0 .. Length - 1) do
         declare
            O : Count := Result'First;
            Buffer : Atom (0 .. 3);
            Accumulated : Count := 0;
         begin
            for I in Data'Range loop
               if Is_Base64_Digit (Data (I)) then
                  Buffer (Accumulated) := Data (I);
                  Accumulated := Accumulated + 1;
                  if Accumulated = 4 then
                     Result (O .. O + 2) := Decode_Base64 (Buffer (0),
                                                           Buffer (1),
                                                           Buffer (2),
                                                           Buffer (3));
                     O := O + 3;
                     Accumulated := 0;
                  end if;
               end if;
            end loop;

            if Accumulated = 2 then
               Result (O .. O) := Decode_Base64 (Buffer (0), Buffer (1));
               O := O + 1;
            elsif Accumulated = 3 then
               Result (O .. O + 1) := Decode_Base64 (Buffer (0),
                                                     Buffer (1),
                                                     Buffer (2));
               O := O + 2;
            end if;

            pragma Assert (O = Length);
         end;
      end return;
   end Decode_Base64;

   ----------------------
   -- Base-64 Encoding --
   ----------------------

   function Encode_Base64 (Value : in Octet) return Octet is
   begin
      case Value is
         when 0 .. 25 =>
            return Upper_A + Value;
         when 26 .. 51 =>
            return Lower_A + Value - 26;
         when 52 .. 61 =>
            return Digit_0 + Value - 52;
         when 62 =>
            return Plus;
         when 63 =>
            return Slash;
         when others =>
            raise Constraint_Error;
      end case;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 (A * 2**4 mod 2**6);
      Output (Output'First + 2) := Base64_Filler;
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A, B : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 (B * 2**2 mod 2**6);
      Output (Output'First + 3) := Base64_Filler;
   end Encode_Base64;

   procedure Encode_Base64 (Output : out Atom; A, B, C : in Octet) is
   begin
      Output (Output'First + 0) := Encode_Base64 (A / 2**2 mod 2**6);
      Output (Output'First + 1) := Encode_Base64 ((A * 2**4 + B / 2**4)
                                                  mod 2**6);
      Output (Output'First + 2) := Encode_Base64 ((B * 2**2 + C / 2**6)
                                                  mod 2**6);
      Output (Output'First + 3) := Encode_Base64 (C mod 2**6);
   end Encode_Base64;

   function Encode_Base64 (Data : in Atom) return Atom is
      Chunks : constant Count := (Data'Length + 2) / 3;
      Result : Atom (0 .. Chunks * 4 - 1);
      Cursor : Offset := Result'First;
      I      : Offset := Data'First;
   begin
      while I in Data'Range loop
         if I + 2 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1),
               Data (I + 2));
            I := I + 3;
         elsif I + 1 in Data'Range then
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I),
               Data (I + 1));
            I := I + 2;
         else
            Encode_Base64
              (Result (Cursor .. Cursor + 3),
               Data (I));
            I := I + 1;
         end if;
         Cursor := Cursor + 4;
      end loop;

      return Result;
   end Encode_Base64;

   ---------------------------------
   -- Base-64 with other charsets --
   ---------------------------------

   function Decode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Recoded : Atom := Data;
   begin
      for I in Recoded'Range loop
         if Recoded (I) = Digit_62 then
            Recoded (I) := Plus;
         elsif Recoded (I) = Digit_63 then
            Recoded (I) := Slash;
         end if;
      end loop;

      return Decode_Base64 (Recoded);
   end Decode_Base64;

   function Encode_Base64 (Data : in Atom; Digit_62, Digit_63 : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
      Last : Count := Result'Last;
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            pragma Assert (Result (I + 1 .. Result'Last)
              = (I + 1 .. Result'Last => Base64_Filler));
            Last := I - 1;
            exit;
         end if;
      end loop;

      return Result (Result'First .. Last);
   end Encode_Base64;

   function Encode_Base64
     (Data : in Atom;
      Digit_62, Digit_63, Padding : in Octet)
     return Atom
   is
      Result : Atom := Encode_Base64 (Data);
   begin
      for I in Result'Range loop
         if Result (I) = Plus then
            Result (I) := Digit_62;
         elsif Result (I) = Slash then
            Result (I) := Digit_63;
         elsif Result (I) = Base64_Filler then
            Result (I) := Padding;
         end if;
      end loop;

      return Result;
   end Encode_Base64;

end Natools.S_Expressions.Encodings;

s_expressions-encodings: replace assert-in-loop by asserting a slice comparison


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

package body Orka.Timers is

   function Create_Timer return Timer is
   begin
      return Timer'(others => <>);
   end Create_Timer;

   use GL.Types;

   function Get_Duration (Value : UInt64) return Duration is
      Seconds     : constant UInt64 := Value / 1e9;
      Nanoseconds : constant UInt64 := Value - Seconds * 1e9;
   begin
      return Duration (Seconds) + Duration (Nanoseconds) / 1e9;
   end Get_Duration;

   procedure Start (Object : in out Timer) is
      use GL.Objects.Queries;
   begin
      if Object.State = Waiting and then Object.Query_Stop.Result_Available then
         declare
            Stop_Time  : constant UInt64 := Object.Query_Stop.Result;
            Start_Time : constant UInt64 := Object.Query_Start.Result;
         begin
            if Stop_Time > Start_Time then
               Object.GPU_Duration := Get_Duration (Stop_Time - Start_Time);
            end if;
         end;
         Object.State := Idle;
      end if;

      if Object.State = Idle then
         Object.CPU_Start := Get_Current_Time;
         Object.Query_Start.Record_Current_Time;
         Object.State := Busy;
      end if;
   end Start;

   procedure Stop (Object : in out Timer) is
      use GL.Objects.Queries;
   begin
      if Object.State = Busy then
         declare
            Current_Time : Long := Get_Current_Time;
         begin
            if Current_Time > Object.CPU_Start then
               Object.CPU_Duration := Get_Duration (UInt64 (Current_Time - Object.CPU_Start));
            end if;
         end;
         Object.Query_Stop.Record_Current_Time;
         Object.State := Waiting;
      end if;
   end Stop;

   function CPU_Duration (Object : Timer) return Duration is (Object.CPU_Duration);

   function GPU_Duration (Object : Timer) return Duration is (Object.GPU_Duration);

end Orka.Timers;

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

package body Orka.Timers is

   function Create_Timer return Timer is
   begin
      return Timer'(others => <>);
   end Create_Timer;

   use GL.Types;

   function Get_Duration (Value : UInt64) return Duration is
      Seconds     : constant UInt64 := Value / 1e9;
      Nanoseconds : constant UInt64 := Value - Seconds * 1e9;
   begin
      return Duration (Seconds) + Duration (Nanoseconds) / 1e9;
   end Get_Duration;

   procedure Start (Object : in out Timer) is
      use GL.Objects.Queries;
   begin
      if Object.State = Waiting and then Object.Query_Stop.Result_Available then
         declare
            Stop_Time  : constant UInt64 := Object.Query_Stop.Result;
            Start_Time : constant UInt64 := Object.Query_Start.Result;
         begin
            if Stop_Time > Start_Time then
               Object.GPU_Duration := Get_Duration (Stop_Time - Start_Time);
            end if;
         end;
         Object.State := Idle;
      end if;

      if Object.State = Idle then
         Object.CPU_Start := Get_Current_Time;
         Object.Query_Start.Record_Current_Time;
         Object.State := Busy;
      end if;
   end Start;

   procedure Stop (Object : in out Timer) is
      use GL.Objects.Queries;
   begin
      if Object.State = Busy then
         declare
            Current_Time : constant Long := Get_Current_Time;
         begin
            if Current_Time > Object.CPU_Start then
               Object.CPU_Duration := Get_Duration (UInt64 (Current_Time - Object.CPU_Start));
            end if;
         end;
         Object.Query_Stop.Record_Current_Time;
         Object.State := Waiting;
      end if;
   end Stop;

   function CPU_Duration (Object : Timer) return Duration is (Object.CPU_Duration);

   function GPU_Duration (Object : Timer) return Duration is (Object.GPU_Duration);

end Orka.Timers;

Make some variables constant

orka: Make some variables constant

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  EL.Variables -- Variable mapper
--  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.
-----------------------------------------------------------------------

package body EL.Variables is

   --  ------------------------------
   --  Get the Value_Expression that corresponds to the given variable name.
   --  ------------------------------
   function Get_Variable (Mapper : in Variable_Mapper'Class;
                          Name   : in Unbounded_String)
                          return EL.Expressions.Value_Expression is
   begin
      return EL.Expressions.Create_Expression (Mapper.Get_Variable (Name));
   end Get_Variable;

   --  ------------------------------
   --  Set the variable to the given value expression.
   --  ------------------------------
   procedure Set_Variable (Mapper : in out Variable_Mapper'Class;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Value_Expression) is
   begin
      Mapper.Set_Variable (Name, EL.Expressions.Expression (Value));
   end Set_Variable;

end EL.Variables;

-----------------------------------------------------------------------
--  EL.Variables -- Variable mapper
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body EL.Variables is

   --  ------------------------------
   --  Get the Value_Expression that corresponds to the given variable name.
   --  ------------------------------
   function Get_Variable (Mapper : in Variable_Mapper'Class;
                          Name   : in Unbounded_String)
                          return EL.Expressions.Value_Expression is
      VE : constant EL.Expressions.Expression := Mapper.Get_Variable (Name);
   begin
      return EL.Expressions.Create_Expression (VE);
   end Get_Variable;

   --  ------------------------------
   --  Set the variable to the given value expression.
   --  ------------------------------
   procedure Set_Variable (Mapper : in out Variable_Mapper'Class;
                           Name   : in Unbounded_String;
                           Value  : in EL.Expressions.Value_Expression) is
   begin
      Mapper.Set_Variable (Name, EL.Expressions.Expression (Value));
   end Set_Variable;

end EL.Variables;

Fix compilation with gcc 4.7

Fix compilation with gcc 4.7


-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

--  with EL.Functions;

limited with Security.Controllers;
limited with Security.Contexts;

--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
package Security.Permissions is

   --  EL function name exposed by Set_Functions.
   HAS_PERMISSION_FN  : constant String := "hasPermission";

   --  URI for the EL functions exposed by the security package (See Set_Functions).
   AUTH_NAMESPACE_URI : constant String := "http://code.google.com/p/ada-asf/auth";

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Permission_Index is new Natural;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permission_Index range <>) of Controller_Access;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Abstract_Permission is abstract tagged limited null record;

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Role_Type) return Boolean is abstract;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

   --  ------------------------------
   --  Permission
   --  ------------------------------

   --  Represents a permission for a given role.
   type Permission (Role : Permission_Type) is new Abstract_Permission with null record;

   --  ------------------------------
   --  URI Permission
   --  ------------------------------
   --  Represents a permission to access a given URI.
   type URI_Permission (Len : Natural) is new Abstract_Permission with record
      URI : String (1 .. Len);
   end record;

   --  ------------------------------
   --  File Permission
   --  ------------------------------

   type File_Mode is (READ, WRITE);

   --  Represents a permission to access a given file.
   type File_Permission (Len  : Natural;
                         Mode : File_Mode) is new Abstract_Permission with record
      Path : String (1 .. Len);
   end record;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Permission_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Permission_Manager;
                       Name    : in String) return Role_Type;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean;

   --  Returns True if the user has the given role permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            User       : in Principal'Class;
                            Permission : in Permission_Type) return Boolean;

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Permission_Manager'Class;
                            Index   : in Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Get the role name.
   function Get_Role_Name (Manager : in Permission_Manager;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Permission_Manager;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Permission_Manager;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out Permission_Manager;
                                   URI     : in String;
                                   To      : in String);

   --  Grant the permission to access to the given Path to users having the To
   --  permissions.
   procedure Grant_File_Permission (Manager : in out Permission_Manager;
                                    Path    : in String;
                                    To      : in String);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Permission_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Permission_Manager);

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Permission_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   --  procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

private

   use Util.Strings;

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  No rule
--     No_Rule : constant Access_Rule := (Count => 0,
--                                        Permissions => (others => Permission_Index'First));

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in Permission_Manager;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Permission_Manager is new Ada.Finalization.Limited_Controlled with record
      Names        : Role_Name_Array;
      Cache        : Rules_Ref_Access;
      Next_Role    : Role_Type := Role_Type'First;
      Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

   --  EL function to check if the given permission name is granted by the current
   --  security context.
   function Has_Permission (Value : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  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.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

limited with Security.Controllers;
limited with Security.Contexts;

--  == Permissions ==
--  The Security.Permissions package defines the different permissions that can be
--  checked by the access control manager.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--
package Security.Permissions is

   --  EL function name exposed by Set_Functions.
   HAS_PERMISSION_FN  : constant String := "hasPermission";

   --  URI for the EL functions exposed by the security package (See Set_Functions).
   AUTH_NAMESPACE_URI : constant String := "http://code.google.com/p/ada-asf/auth";

   Invalid_Name : exception;

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Permission_Index is new Natural;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is array (Permission_Index range <>) of Controller_Access;

   --  Get the permission index associated with the name.
   function Get_Permission_Index (Name : in String) return Permission_Index;

   --  Get the last permission index registered in the global permission map.
   function Get_Last_Permission_Index return Permission_Index;

   --  Add the permission name and allocate a unique permission index.
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index);

   --  The permission root class.
   type Abstract_Permission is abstract tagged limited null record;

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Each permission is represented by a Permission_Type number to provide a fast
   --  and efficient permission check.
   type Permission_Type is new Natural range 0 .. 63;

   --  The Permission_Map represents a set of permissions which are granted to a user.
   --  Each permission is represented by a boolean in the map.  The implementation is limited
   --  to 64 permissions.
   type Permission_Map is array (Permission_Type'Range) of Boolean;
   pragma Pack (Permission_Map);

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Role_Type) return Boolean is abstract;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

   --  ------------------------------
   --  Permission
   --  ------------------------------

   --  Represents a permission for a given role.
   type Permission (Role : Permission_Type) is new Abstract_Permission with null record;

   --  ------------------------------
   --  URI Permission
   --  ------------------------------
   --  Represents a permission to access a given URI.
   type URI_Permission (Len : Natural) is new Abstract_Permission with record
      URI : String (1 .. Len);
   end record;

   --  ------------------------------
   --  File Permission
   --  ------------------------------

   type File_Mode is (READ, WRITE);

   --  Represents a permission to access a given file.
   type File_Permission (Len  : Natural;
                         Mode : File_Mode) is new Abstract_Permission with record
      Path : String (1 .. Len);
   end record;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Permission_Manager is new Ada.Finalization.Limited_Controlled with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   procedure Add_Permission (Manager    : in out Permission_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Permission_Manager;
                       Name    : in String) return Role_Type;

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean;

   --  Returns True if the user has the given role permission.
   function Has_Permission (Manager    : in Permission_Manager;
                            User       : in Principal'Class;
                            Permission : in Permission_Type) return Boolean;

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Permission_Manager'Class;
                            Index   : in Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Get the role name.
   function Get_Role_Name (Manager : in Permission_Manager;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Permission_Manager;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Permission_Manager;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out Permission_Manager;
                                   URI     : in String;
                                   To      : in String);

   --  Grant the permission to access to the given Path to users having the To
   --  permissions.
   procedure Grant_File_Permission (Manager : in out Permission_Manager;
                                    Path    : in String;
                                    To      : in String);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Permission_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Permission_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Permission_Manager);

   generic
      Name : String;
   package Permission_ACL is
      function Permission return Permission_Index;
      pragma Inline_Always (Permission);
   end Permission_ACL;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : Permission_Manager_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Security.Permissions.Permission_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

   --  Register a set of functions in the namespace
   --  xmlns:fn="http://code.google.com/p/ada-asf/auth"
   --  Functions:
   --    hasPermission(NAME)   --  Returns True if the permission NAME is granted
   --  procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

private

   use Util.Strings;

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Permission_Type_Array is array (1 .. 10) of Permission_Type;

   type Permission_Index_Array is array (Positive range <>) of Permission_Index;

   --  The Access_Rule represents a list of permissions to verify to grant
   --  access to the resource.  To make it simple, the user must have one of the
   --  permission from the list.  Each permission will refer to a specific permission
   --  controller.
   type Access_Rule (Count : Natural) is new Util.Refs.Ref_Entity with record
      Permissions : Permission_Index_Array (1 .. Count);
   end record;
   type Access_Rule_Access is access all Access_Rule;

   package Access_Rule_Refs is
     new Util.Refs.Indefinite_References (Element_Type   => Access_Rule,
                                          Element_Access => Access_Rule_Access);
   subtype Access_Rule_Ref is Access_Rule_Refs.Ref;

   --  No rule
--     No_Rule : constant Access_Rule := (Count => 0,
--                                        Permissions => (others => Permission_Index'First));

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in Permission_Manager;
                              URI     : in String) return Access_Rule_Ref;

   --  The Policy defines the access rules that are applied on a given
   --  URL, set of URLs or files.
   type Policy is record
      Id      : Natural;
      Pattern : GNAT.Regexp.Regexp;
      Rule    : Access_Rule_Ref;
   end record;

   --  The Policy_Vector represents the whole permission policy.  The order of
   --  policy in the list is important as policies can override each other.
   package Policy_Vector is new Ada.Containers.Vectors (Index_Type   => Positive,
                                                        Element_Type => Policy);

   package Rules_Maps is new Ada.Containers.Hashed_Maps (Key_Type        => String_Ref,
                                                         Element_Type    => Access_Rule_Ref,
                                                         Hash            => Hash,
                                                         Equivalent_Keys => Equivalent_Keys,
                                                         "="             => Access_Rule_Refs."=");

   type Rules is new Util.Refs.Ref_Entity with record
      Map : Rules_Maps.Map;
   end record;
   type Rules_Access is access all Rules;

   package Rules_Ref is new Util.Refs.References (Rules, Rules_Access);

   type Rules_Ref_Access is access Rules_Ref.Atomic_Ref;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Permission_Manager is new Ada.Finalization.Limited_Controlled with record
      Names        : Role_Name_Array;
      Cache        : Rules_Ref_Access;
      Next_Role    : Role_Type := Role_Type'First;
      Policies     : Policy_Vector.Vector;
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;
   end record;

   --  EL function to check if the given permission name is granted by the current
   --  security context.
   function Has_Permission (Value : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

end Security.Permissions;

Document the permission and principal

Document the permission and principal


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

   type Natural_Access is access all Natural;

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

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

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

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

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

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

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

      type Local_Parser is new Parser with null record;

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

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

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

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

      type Local_Parser is new Parser with null record;

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

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

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

end Util.Properties.JSON;

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

   type Natural_Access is access all Natural;

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

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

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

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

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

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

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

      type Local_Parser is new Parser with null record;

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

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

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse_String (Content);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

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

      type Local_Parser is new Parser with null record;

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

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

      P : Local_Parser;
   begin
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

Raise a Parse_Error exception if there is an error while parsing the JSON content


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

with Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wide_Wide_Character) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String);

   function Is_Letter (C : in Wide_Wide_Character) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      Name := To_Unbounded_Wide_Wide_String ("");
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Ada.Strings.Wide_Wide_Unbounded.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C     : Wide_Wide_Character;
      Token : Wide_Wide_Character;
   begin
      Value := To_Unbounded_Wide_Wide_String ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wide_Wide_Character;
      Name  : Unbounded_Wide_Wide_String;
      Value : Unbounded_Wide_Wide_String;
   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Wiki.Helpers.Is_Space (C) and Length (Name) > 0 then
            Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wide_Wide_Character;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      Name : Unbounded_Wide_Wide_String;
      C    : Wide_Wide_Character;
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      if C = '/' then
         Skip_Spaces (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
         Flush_Text (P);
         End_Element (P, Name);
      else
         Collect_Attributes (P);
         Peek (P, C);
         if C = '/' then
            Peek (P, C);
            if C = '>' then
               Start_Element (P, Name, P.Attributes);
               End_Element (P, Name);
               return;
            end if;
         elsif C /= '>' then
            Put_Back (P, C);
         end if;
         Start_Element (P, Name, P.Attributes);
      end if;
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wide_Wide_Character) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wide_Wide_Character;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Ada.Characters.Conversions.To_Character (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Ada.Characters.Conversions.To_Wide_Wide_Character (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

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

with Wiki.Helpers;
with Wiki.Parsers.Html.Entities;
package body Wiki.Parsers.Html is

   --  Parse an HTML attribute
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String);

   --  Parse a HTML/XML comment to strip it.
   procedure Parse_Comment (P : in out Parser);

   --  Parse a simple DOCTYPE declaration and ignore it.
   procedure Parse_Doctype (P : in out Parser);

   procedure Collect_Attributes (P     : in out Parser);
   function Is_Letter (C : in Wide_Wide_Character) return Boolean;
   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String);

   function Is_Letter (C : in Wide_Wide_Character) return Boolean is
   begin
      return C > ' ' and C /= ':' and C /= '>' and C /= ''' and C /= '"'
        and C /= '/' and C /= '=' and C /= '<';
   end Is_Letter;

   --  ------------------------------
   --  Parse an HTML attribute
   --  ------------------------------
   procedure Parse_Attribute_Name (P    : in out Parser;
                                   Name : in out Unbounded_Wide_Wide_String) is
      C : Wide_Wide_Character;
   begin
      Name := To_Unbounded_Wide_Wide_String ("");
      Skip_Spaces (P);
      while not P.Is_Eof loop
         Peek (P, C);
         if not Is_Letter (C) then
            Put_Back (P, C);
            return;
         end if;
         Ada.Strings.Wide_Wide_Unbounded.Append (Name, C);
      end loop;
   end Parse_Attribute_Name;

   procedure Collect_Attribute_Value (P     : in out Parser;
                                      Value : in out Unbounded_Wide_Wide_String) is
      C     : Wide_Wide_Character;
      Token : Wide_Wide_Character;
   begin
      Value := To_Unbounded_Wide_Wide_String ("");
      Peek (P, Token);
      if Wiki.Helpers.Is_Space (Token) then
         return;
      elsif Token = '>' then
         Put_Back (P, Token);
         return;
      elsif Token /= ''' and Token /= '"' then
         Append (Value, Token);
         while not P.Is_Eof loop
            Peek (P, C);
            if C = ''' or C = '"' or C = ' ' or C = '=' or C = '>' or C = '<' or C = '`' then
               Put_Back (P, C);
               return;
            end if;
            Append (Value, C);
         end loop;
      else
         while not P.Is_Eof loop
            Peek (P, C);
            if C = Token then
               return;
            end if;
            Append (Value, C);
         end loop;
      end if;
   end Collect_Attribute_Value;

   --  ------------------------------
   --  Parse a list of HTML attributes up to the first '>'.
   --  attr-name
   --  attr-name=
   --  attr-name=value
   --  attr-name='value'
   --  attr-name="value"
   --  <name name='value' ...>
   --  ------------------------------
   procedure Collect_Attributes (P     : in out Parser) is
      C     : Wide_Wide_Character;
      Name  : Unbounded_Wide_Wide_String;
      Value : Unbounded_Wide_Wide_String;
   begin
      Wiki.Attributes.Clear (P.Attributes);
      while not P.Is_Eof loop
         Parse_Attribute_Name (P, Name);
         Skip_Spaces (P);
         Peek (P, C);
         if C = '>' or C = '<' or C = '/' then
            Put_Back (P, C);
            exit;
         end if;
         if C = '=' then
            Collect_Attribute_Value (P, Value);
            Attributes.Append (P.Attributes, Name, Value);
         elsif Wiki.Helpers.Is_Space (C) and Length (Name) > 0 then
            Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
         end if;
      end loop;
      --  Peek (P, C);

      --  Add any pending attribute.
      if Length (Name) > 0 then
         Attributes.Append (P.Attributes, Name, Null_Unbounded_Wide_Wide_String);
      end if;
   end Collect_Attributes;

   --  ------------------------------
   --  Parse a HTML/XML comment to strip it.
   --  ------------------------------
   procedure Parse_Comment (P : in out Parser) is
      C     : Wide_Wide_Character;
   begin
      Peek (P, C);
      while not P.Is_Eof loop
         Peek (P, C);
         if C = '-' then
            declare
               Count : Natural := 1;
            begin
               Peek (P, C);
               while not P.Is_Eof and C = '-' loop
                  Peek (P, C);
                  Count := Count + 1;
               end loop;
               exit when C = '>' and Count >= 2;
            end;
         end if;
      end loop;
   end Parse_Comment;

   --  ------------------------------
   --  Parse a simple DOCTYPE declaration and ignore it.
   --  ------------------------------
   procedure Parse_Doctype (P : in out Parser) is
      C : Wide_Wide_Character;
   begin
      while not P.Is_Eof loop
         Peek (P, C);
         exit when C = '>';
      end loop;
   end Parse_Doctype;

   --  ------------------------------
   --  Parse a HTML element <XXX attributes>
   --  or parse an end of HTML element </XXX>
   --  ------------------------------
   procedure Parse_Element (P : in out Parser) is
      Name : Unbounded_Wide_Wide_String;
      C    : Wide_Wide_Character;
      Tag  : Wiki.Nodes.Html_Tag_Type;
   begin
      Peek (P, C);
      if C = '!' then
         Peek (P, C);
         if C = '-' then
            Parse_Comment (P);
         else
            Parse_Doctype (P);
         end if;
         return;
      end if;
      if C /= '/' then
         Put_Back (P, C);
      end if;
      Parse_Attribute_Name (P, Name);
      Tag := Wiki.Nodes.Find_Tag (To_Wide_Wide_String (Name));
      if C = '/' then
         Skip_Spaces (P);
         Peek (P, C);
         if C /= '>' then
            Put_Back (P, C);
         end if;
         Flush_Text (P);
         End_Element (P, Tag);
      else
         Collect_Attributes (P);
         Peek (P, C);
         if C = '/' then
            Peek (P, C);
            if C = '>' then
               Start_Element (P, Tag, P.Attributes);
               End_Element (P, Tag);
               return;
            end if;
         elsif C /= '>' then
            Put_Back (P, C);
         end if;
         Start_Element (P, Tag, P.Attributes);
      end if;
   end Parse_Element;

   --  ------------------------------
   --  Parse an HTML entity such as   and replace it with the corresponding code.
   --  ------------------------------
   procedure Parse_Entity (P     : in out Parser;
                           Token : in Wide_Wide_Character) is
      pragma Unreferenced (Token);

      Name : String (1 .. 10);
      Len  : Natural := 0;
      High : Natural := Wiki.Parsers.Html.Entities.Keywords'Last;
      Low  : Natural := Wiki.Parsers.Html.Entities.Keywords'First;
      Pos  : Natural;
      C    : Wide_Wide_Character;
   begin
      while Len < Name'Last loop
         Peek (P, C);
         exit when C = ';' or else P.Is_Eof;
         Len := Len + 1;
         Name (Len) := Ada.Characters.Conversions.To_Character (C);
      end loop;
      while Low <= High loop
         Pos := (Low + High) / 2;
         if Wiki.Parsers.Html.Entities.Keywords (Pos).all = Name (1 .. Len) then
            Parse_Text (P, Entities.Mapping (Pos));
            return;
         elsif Entities.Keywords (Pos).all < Name (1 .. Len) then
            Low := Pos + 1;
         else
            High := Pos - 1;
         end if;
      end loop;

      --  The HTML entity is not recognized: we must treat it as plain wiki text.
      Parse_Text (P, '&');
      for I in 1 .. Len loop
         Parse_Text (P, Ada.Characters.Conversions.To_Wide_Wide_Character (Name (I)));
      end loop;
   end Parse_Entity;

end Wiki.Parsers.Html;

Use Wiki.Nodes.Find_Tag to find the HTML tag and call the Start_Element/End_Element operation