with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Text_IO;
with Ada.Integer_Text_IO;
with GNAT.Table;
package body GNAT.CGI.Cookie is
use Ada;
Valid_Environment : Boolean := False;
Header_Sent : Boolean := False;
type String_Access is access String;
type Cookie_Data is record
Key : String_Access;
Value : String_Access;
Comment : String_Access;
Domain : String_Access;
Max_Age : Natural;
Path : String_Access;
Secure : Boolean := False;
end record;
type Key_Value is record
Key, Value : String_Access;
end record;
package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
procedure Check_Environment;
pragma Inline (Check_Environment);
procedure Initialize;
procedure Check_Environment is
begin
if not Valid_Environment then
raise Data_Error;
end if;
end Check_Environment;
function Count return Natural is
begin
return Key_Value_Table.Last;
end Count;
function 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 Exists;
procedure For_Every_Cookie 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_Cookie;
procedure Initialize is
HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
procedure Set_Parameter_Table (Data : String);
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;
Sep : 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
Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
Add_Parameter (K, Data (Index .. Sep - 1));
Index := Sep + 2;
end loop;
Add_Parameter (Count, Data (Index .. Data'Last));
end Set_Parameter_Table;
begin
if HTTP_COOKIE /= "" then
Set_Parameter_Table (HTTP_COOKIE);
end if;
Valid_Environment := True;
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 Cookie_Not_Found;
end if;
end Key;
function Ok return Boolean is
begin
return Valid_Environment;
end Ok;
procedure Put_Header
(Header : String := Default_Header;
Force : Boolean := False)
is
procedure Output_Cookies;
procedure Output_Cookies is
procedure Output_One_Cookie
(Key : String;
Value : String;
Comment : String;
Domain : String;
Max_Age : Natural;
Path : String;
Secure : Boolean);
procedure Output_One_Cookie
(Key : String;
Value : String;
Comment : String;
Domain : String;
Max_Age : Natural;
Path : String;
Secure : Boolean)
is
begin
Text_IO.Put ("Set-Cookie: ");
Text_IO.Put (Key & '=' & Value);
if Comment /= "" then
Text_IO.Put ("; Comment=" & Comment);
end if;
if Domain /= "" then
Text_IO.Put ("; Domain=" & Domain);
end if;
if Max_Age /= Natural'Last then
Text_IO.Put ("; Max-Age=");
Integer_Text_IO.Put (Max_Age, Width => 0);
end if;
if Path /= "" then
Text_IO.Put ("; Path=" & Path);
end if;
if Secure then
Text_IO.Put ("; Secure");
end if;
Text_IO.New_Line;
end Output_One_Cookie;
begin
for C in 1 .. Cookie_Table.Last loop
Output_One_Cookie (Cookie_Table.Table (C).Key.all,
Cookie_Table.Table (C).Value.all,
Cookie_Table.Table (C).Comment.all,
Cookie_Table.Table (C).Domain.all,
Cookie_Table.Table (C).Max_Age,
Cookie_Table.Table (C).Path.all,
Cookie_Table.Table (C).Secure);
end loop;
end Output_Cookies;
begin
if Header_Sent = False or else Force then
Check_Environment;
Text_IO.Put_Line (Header);
Output_Cookies;
Text_IO.New_Line;
Header_Sent := True;
end if;
end Put_Header;
procedure Set
(Key : String;
Value : String;
Comment : String := "";
Domain : String := "";
Max_Age : Natural := Natural'Last;
Path : String := "/";
Secure : Boolean := False) is
begin
Cookie_Table.Increment_Last;
Cookie_Table.Table (Cookie_Table.Last) :=
Cookie_Data'(new String'(Key),
new String'(Value),
new String'(Comment),
new String'(Domain),
Max_Age,
new String'(Path),
Secure);
end Set;
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 Cookie_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 Cookie_Not_Found;
end if;
end Value;
begin
Initialize;
end GNAT.CGI.Cookie;