ada/PolyORB
0
0
Fork 0
mirror of https://github.com/AdaCore/PolyORB.git synced 2026-02-12 13:01:15 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
22.1
PolyORB/src/polyorb-utils.adb

328 lines
9.5 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- --
-- 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- 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_2012;
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;
Reference in New Issue View Git Blame Copy Permalink