with Ada.Text_IO;
with Ada.Strings.Fixed;
with Ada.Characters.Handling;
with Ada.Strings.Maps;
with GNAT.OS_Lib;
with GNAT.Table;
package body GNAT.CGI is
use Ada;
Valid_Environment : Boolean := True;
Current_Method : Method_Type;
Header_Sent : Boolean := False;
type String_Access is access String;
type Key_Value is record
Key : String_Access;
Value : String_Access;
end record;
package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
procedure Check_Environment;
pragma Inline (Check_Environment);
procedure Initialize;
function Argument_Count return Natural is
begin
Check_Environment;
return Key_Value_Table.Last;
end Argument_Count;
procedure Check_Environment is
begin
if not Valid_Environment then
raise Data_Error;
end if;
end Check_Environment;
function Decode (S : String) return String is
Result : String (S'Range);
K : Positive := S'First;
J : Positive := Result'First;
begin
while K <= S'Last loop
if K + 2 <= S'Last
and then S (K) = '%'
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
then
Result (J) := Character'Val
(Natural'Value ("16#" & S (K + 1 .. K + 2) & '#'));
K := K + 3;
else
Result (J) := S (K);
K := K + 1;
end if;
J := J + 1;
end loop;
return Result (Result'First .. J - 1);
end Decode;
procedure For_Every_Parameter is
Quit : Boolean;
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
Quit := False;
Action (Key_Value_Table.Table (K).Key.all,
Key_Value_Table.Table (K).Value.all,
K,
Quit);
exit when Quit;
end loop;
end For_Every_Parameter;
procedure Initialize is
Request_Method : constant String :=
Characters.Handling.To_Upper
(Metavariable (CGI.Request_Method));
procedure Initialize_GET;
procedure Initialize_POST;
procedure Set_Parameter_Table (Data : String);
procedure Initialize_GET is
Data : constant String := Metavariable (Query_String);
begin
Current_Method := Get;
if Data /= "" then
Set_Parameter_Table (Data);
end if;
end Initialize_GET;
procedure Initialize_POST is
Content_Length : constant Natural :=
Natural'Value (Metavariable (CGI.Content_Length));
Data : String (1 .. Content_Length);
begin
Current_Method := Post;
if Content_Length /= 0 then
Text_IO.Get (Data);
Set_Parameter_Table (Data);
end if;
end Initialize_POST;
procedure Set_Parameter_Table (Data : String) is
procedure Add_Parameter (K : Positive; P : String);
Count : constant Positive :=
1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&"));
Index : Positive := Data'First;
Amp : Natural;
procedure Add_Parameter (K : Positive; P : String) is
Equal : constant Natural := Strings.Fixed.Index (P, "=");
begin
if Equal = 0 then
raise Data_Error;
else
Key_Value_Table.Table (K) :=
Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
new String'(Decode (P (Equal + 1 .. P'Last))));
end if;
end Add_Parameter;
begin
Key_Value_Table.Set_Last (Count);
for K in 1 .. Count - 1 loop
Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
Add_Parameter (K, Data (Index .. Amp - 1));
Index := Amp + 1;
end loop;
Add_Parameter (Count, Data (Index .. Data'Last));
end Set_Parameter_Table;
begin
if Request_Method = "GET" then
Initialize_GET;
elsif Request_Method = "POST" then
Initialize_POST;
else
Valid_Environment := False;
end if;
exception
when others =>
Valid_Environment := False;
end Initialize;
function Key (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Key.all;
else
raise Parameter_Not_Found;
end if;
end Key;
function Key_Exists (Key : String) return Boolean is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return True;
end if;
end loop;
return False;
end Key_Exists;
function Metavariable
(Name : Metavariable_Name;
Required : Boolean := False) return String
is
function Get_Environment (Variable_Name : String) return String;
function Get_Environment (Variable_Name : String) return String is
Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
Result : constant String := Value.all;
begin
OS_Lib.Free (Value);
return Result;
end Get_Environment;
Result : constant String :=
Get_Environment (Metavariable_Name'Image (Name));
begin
Check_Environment;
if Result = "" and then Required then
raise Parameter_Not_Found;
else
return Result;
end if;
end Metavariable;
function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
begin
Check_Environment;
if Metavariable (Name) = "" then
return False;
else
return True;
end if;
end Metavariable_Exists;
function Method return Method_Type is
begin
Check_Environment;
return Current_Method;
end Method;
function Ok return Boolean is
begin
return Valid_Environment;
end Ok;
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False)
is
begin
if Header_Sent = False or else Force then
Check_Environment;
Text_IO.Put_Line (Header);
Text_IO.New_Line;
Header_Sent := True;
end if;
end Put_Header;
function URL return String is
function Exists_And_Not_80 (Server_Port : String) return String;
function Exists_And_Not_80 (Server_Port : String) return String is
begin
if Server_Port = "80" then
return "";
else
return ':' & Server_Port;
end if;
end Exists_And_Not_80;
begin
Check_Environment;
return "http://"
& Metavariable (Server_Name)
& Exists_And_Not_80 (Metavariable (Server_Port))
& Metavariable (Script_Name);
end URL;
function Value
(Key : String;
Required : Boolean := False)
return String
is
begin
Check_Environment;
for K in 1 .. Key_Value_Table.Last loop
if Key_Value_Table.Table (K).Key.all = Key then
return Key_Value_Table.Table (K).Value.all;
end if;
end loop;
if Required then
raise Parameter_Not_Found;
else
return "";
end if;
end Value;
function Value (Position : Positive) return String is
begin
Check_Environment;
if Position <= Key_Value_Table.Last then
return Key_Value_Table.Table (Position).Value.all;
else
raise Parameter_Not_Found;
end if;
end Value;
begin
Initialize;
end GNAT.CGI;