------------------------------------------------------------------------------
--                                                                          --
--                           POLYORB COMPONENTS                             --
--                                                                          --
--                        P O L Y O R B . U T I L S                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 2001-2012, Free Software Foundation, Inc.          --
--                                                                          --
-- This is free software;  you can redistribute it  and/or modify it  under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  This software is distributed in the hope  that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for  more details.                                               --
--                                                                          --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
--                  PolyORB is maintained by AdaCore                        --
--                     (email: sales@adacore.com)                           --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2005;

package body PolyORB.Utils is

   use Ada.Streams;

   ------------------------
   -- Local declarations --
   ------------------------

   Hex : constant array (16#0# .. 16#f#) of Character :=
     "0123456789abcdef";

   Hex_Val : constant array (Character) of Integer :=
     ('0' => 0,
      '1' => 1,
      '2' => 2,
      '3' => 3,
      '4' => 4,
      '5' => 5,
      '6' => 6,
      '7' => 7,
      '8' => 8,
      '9' => 9,
      'A' => 10,
      'a' => 10,
      'B' => 11,
      'b' => 11,
      'C' => 12,
      'c' => 12,
      'D' => 13,
      'd' => 13,
      'E' => 14,
      'e' => 14,
      'F' => 15,
      'f' => 15,
      others => -1);

   type Escape_Map is array (Character) of Boolean;

   Default_Escape_Map : constant Escape_Map :=
     (Character'Val (0) .. Character'Val (16#1f#) |
      ';' | '?' | ':' | '@' | '&' | '=' | '+' | '$' |
      ',' | '<' | '>' | '#' | '%' | '"' | '{' | '}' |
      '|' | '\' | '^' | '[' | ']' | '`' => True,
      others                            => False);

   ---------------
   -- Hex_Value --
   ---------------

   function Hex_Value (C : Character) return Integer is
      V : constant Integer := Hex_Val (C);
   begin
      if V = -1 then
         raise Constraint_Error;
      else
         return V;
      end if;
   end Hex_Value;

   -----------------------
   -- SEA_To_Hex_String --
   -----------------------

   function SEA_To_Hex_String (A : Stream_Element_Array) return String is
      S : String (1 .. 2 * A'Length);
   begin
      for J in A'Range loop
         S (S'First + 2 * Integer (J - A'First))
           := Hex (Integer (A (J)) / 16);
         S (S'First + 2 * Integer (J - A'First) + 1)
           := Hex (Integer (A (J)) mod 16);
      end loop;

      return S;
   end SEA_To_Hex_String;

   -----------------------
   -- Hex_String_To_SEA --
   -----------------------

   function Hex_String_To_SEA (S : String) return Stream_Element_Array is
      A : Stream_Element_Array (1 .. S'Length / 2);
   begin
      for J in A'Range loop
         A (J) :=
           Stream_Element
           (Hex_Value (S (S'First + 2 * Integer (J - A'First))) * 16
            + Hex_Value (S (S'First + 2 * Integer (J - A'First) + 1)));
      end loop;

      return A;
   end Hex_String_To_SEA;

   ----------------
   -- URI_Encode --
   ----------------

   function URI_Encode
     (S : String; Also_Escape : String := "/") return String
   is
      Need_Escape : Escape_Map := Default_Escape_Map;
      Result      : String (1 .. 3 * S'Length);
      DI          : Integer := Result'First;
   begin
      for J in Also_Escape'Range loop
         Need_Escape (Also_Escape (J)) := True;
      end loop;

      for SI in S'Range loop
         if Need_Escape (S (SI)) then
            Result (DI .. DI + 2) :=
              '%'
              & Hex (Character'Pos (S (SI)) / 16)
              & Hex (Character'Pos (S (SI)) mod 16);
            DI := DI + 3;
         else
            Result (DI) := S (SI);
            DI := DI + 1;
         end if;
      end loop;

      return Result (Result'First .. DI - 1);
   end URI_Encode;

   ----------------
   -- URI_Decode --
   ----------------

   function URI_Decode (S : String) return String is
      Result : String (S'Range);
      SI     : Integer := S'First;
      DI     : Integer := Result'First;
   begin
      while SI <= S'Last loop
         if S (SI) = '%' then
            if SI > S'Last - 2 then
               raise Constraint_Error;
            end if;
            Result (DI) := Character'Val
              (Hex_Value (S (SI + 1)) * 16 + Hex_Value (S (SI + 2)));
            SI := SI + 3;
         else
            Result (DI) := S (SI);
            SI := SI + 1;
         end if;
         DI := DI + 1;
      end loop;

      return Result (Result'First .. DI - 1);
   end URI_Decode;

   ---------------
   -- Find_Skip --
   ---------------

   function Find_Skip
     (S         : String;
      Start     : Integer;
      What      : Character;
      Skip      : Boolean;
      Direction : Direction_Type) return Integer
   is
      I : Integer := Start;
   begin
      loop
         exit when I not in S'Range or else (S (I) = What xor Skip);
         I := I + Integer (Direction);
      end loop;

      return I;
   end Find_Skip;

   ----------------
   -- Has_Prefix --
   ----------------

   function Has_Prefix (S : String; Prefix : String) return Boolean is
   begin
      return S'Length >= Prefix'Length
        and then S (S'First .. S'First + Prefix'Length - 1) = Prefix;
   end Has_Prefix;

   -----------------
   -- To_Interval --
   -----------------

   function To_Interval (S : String) return Interval is
      Hyphen : constant Natural := Find (S, S'First, '-');
      --  Index of hyphen in S, or S'Last + 1 if none

      Result : Interval;

   begin
      if Hyphen = S'First or else Hyphen = S'Last then
         --  Malformed interval: if hyphen is present, it must be
         --  preceded and followed by bounds.

         raise Constraint_Error with "malformed interval: " & S;
      end if;

      --  Set result

      Result.Lo := Integer'Value (S (S'First .. Hyphen - 1));

      --  If Hyphen is present, high bound is given explicitly, else we have
      --  a plain integer literal, and treat it as a single-value interval.

      if Hyphen < S'Last then
         Result.Hi := Integer'Value (S (Hyphen + 1 .. S'Last));
      else
         Result.Hi := Result.Lo;
      end if;

      return Result;
   end To_Interval;

   --------------
   -- To_Lower --
   --------------

   function To_Lower (S : String) return String is

      function To_Lower (C : Character) return Character;
      --  Return C converted to lowercase, or unchanged if not an uppercase
      --  letter.

      --------------
      -- To_Lower --
      --------------

      function To_Lower (C : Character) return Character is
         C_Val : constant Natural := Character'Pos (C);

      begin
         if C in 'A' .. 'Z'
           or else C_Val in 16#C0# .. 16#D6#
           or else C_Val in 16#D8# .. 16#DE#
         then
            return Character'Val (C_Val + 16#20#);
         else
            return C;
         end if;
      end To_Lower;

      Result : String := S;

   begin
      for J in Result'Range loop
         Result (J) := To_Lower (Result (J));
      end loop;

      return Result;
   end To_Lower;

   --------------
   -- To_Upper --
   --------------

   function To_Upper (S : String) return String is

      function To_Upper (C : Character) return Character;
      --  Return C converted to uppercase, or unchanged if not a lowercase
      --  letter.

      --------------
      -- To_Upper --
      --------------

      function To_Upper (C : Character) return Character is
         C_Val : constant Natural := Character'Pos (C);

      begin
         if C in 'a' .. 'z'
           or else C_Val in 16#E0# .. 16#F6#
           or else C_Val in 16#F8# .. 16#FE#
         then
            return Character'Val (C_Val - 16#20#);
         else
            return C;
         end if;
      end To_Upper;

      Result : String := S;

   begin
      for J in Result'Range loop
         Result (J) := To_Upper (Result (J));
      end loop;

      return Result;
   end To_Upper;

end PolyORB.Utils;
