* Re: cookies
1998-09-17 0:00 cookies Lisa Winkworth
@ 1998-09-17 0:00 ` Pascal Obry
1998-09-17 0:00 ` cookies Dale Stanbrough
0 siblings, 1 reply; 5+ messages in thread
From: Pascal Obry @ 1998-09-17 0:00 UTC (permalink / raw)
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1: Type: text/plain, Size: 12086 bytes --]
Lisa Winkworth a �crit dans le message <6tpv6c$o1l$1@emu.cs.rmit.edu.au>...
>Hi, does anyone have any idea how to accept/generally do stuff with cookies
>in ada95??
>Any help would be much appreciated :)
>Thanks in advance,
>Lisa
>
Lisa,
I have done a child package of cgi.ads (from David A. Wheeler) to handle
cookies.
The packages spec/body are small so I have included them in this message.
Pascal.
---------------------------------- CUT
HERE -----------------------------------------------
-- File Name : cgi-cookies.ads
--
-- Created by : Pascal Obry
-- on : Mon Mar 10 16:05:01 1997
with Ada.Strings.Unbounded;
package CGI.Cookies is
use Ada.Strings.Unbounded;
-- Get cookie number
function Count return Natural;
-- Get cookies value
function Value
(Key : in Unbounded_String;
Required : in Boolean := False)
return Unbounded_String;
function Value
(Key : in String;
Required : in Boolean := False)
return Unbounded_String;
function Value
(Key : in String;
Required : in Boolean := False)
return String;
function Value
(Key : in Unbounded_String;
Required : in Boolean := False)
return String;
-- Was a given key provided?
function Key_Exists (Key : in String) return Boolean;
function Key_Exists (Key : in Unbounded_String) return Boolean;
-- Set cookies value
procedure Set (Key : in String;
Value : in String;
Expires : in String := "";
Path : in String := "/";
Domain : in String := "";
Secure : in Boolean := False);
-- Send cookies to client with HTML header.
procedure Put_CGI_Header_With_Cookies
(Header : in String := "Content-type: text/html");
end CGI.Cookies;
-- File Name : cgi-cookies.adb
--
-- Created by : Pascal Obry
-- on : Mon Mar 10 16:05:01 1997
with Ada.Text_IO;
with Ada.Strings.Maps;
with Ada.Characters.Handling;
with Table_Of_Static_Keys_And_Static_Values_G;
package body CGI.Cookies is
use Ada;
use Ada.Strings.Maps;
-- to set cookie
type Key_Values_Record is
record
Value : Unbounded_String;
Expires : Unbounded_String;
Path : Unbounded_String;
Domain : Unbounded_String;
Secure : Boolean := False;
end record;
package Cookie_Table is
new Table_Of_Static_Keys_And_Static_Values_G (Unbounded_String,
"<",
"=",
Key_Values_Record);
-- to hold cookie value sent be the client
type Key_Value_Pair is
record
Key : Unbounded_String;
Value : Unbounded_String;
end record;
type Key_Value_Sequence is array (Positive range <>) of Key_Value_Pair;
type Access_Key_Value_Sequence is access Key_Value_Sequence;
-- The following are data internal to this package.
Cookie_Data : Access_Key_Value_Sequence;
Set_Cookie_Data : Cookie_Table.Table_Type;
Ampersands : constant Character_Set := To_Set ('&');
Equals : constant Character_Set := To_Set ('=');
Plus_To_Space : constant Character_Mapping := To_Mapping ("+", " ");
------------------------------
-- Get cookie number
function Count return Natural is
begin
if Cookie_Data = null then
return 0;
else
return Cookie_Data'Length;
end if;
end Count;
------------------------------
-- Get cookies value
function Value
(Key : in Unbounded_String;
Required : in Boolean := False)
return Unbounded_String is
begin
for I in 1 .. Count loop
if Cookie_Data (I).Key = Key then
return Cookie_Data (I).Value;
end if;
end loop;
-- Didn't find the Key.
if Required then
raise Constraint_Error;
else
return Null_Unbounded_String;
end if;
end Value;
------------------------------
function Value
(Key : in String;
Required : in Boolean := False)
return Unbounded_String
is
begin
return Value (To_Unbounded_String (Key), Required);
end Value;
------------------------------
function Value
(Key : in String;
Required : in Boolean := False)
return String
is
begin
return To_String (Value (To_Unbounded_String (Key), Required));
end Value;
------------------------------
function Value
(Key : in Unbounded_String;
Required : in Boolean := False)
return String
is
begin
return To_String (Value (Key, Required));
end Value;
------------------------------
-- Was a given key provided?
function Key_Exists (Key : in Unbounded_String)
return Boolean
is
begin
for I in 1 .. Count loop
if Cookie_Data (I).Key = Key then
return True;
end if;
end loop;
return False;
end Key_Exists;
------------------------------
function Key_Exists (Key : in String)
return Boolean
is
begin
return Key_Exists (To_Unbounded_String (Key));
end Key_Exists;
------------------------------
-- Set cookie value
procedure Set (Key : in String;
Value : in String;
Expires : in String := "";
Path : in String := "/";
Domain : in String := "";
Secure : in Boolean := False)
is
Cookie_Record : Key_Values_Record;
begin -- Set_Cookies
Cookie_Record := (To_Unbounded_String (Value),
To_Unbounded_String (Expires),
To_Unbounded_String (Path),
To_Unbounded_String (Domain),
Secure);
Cookie_Table.Insert_Or_Replace_Value (Set_Cookie_Data,
To_Unbounded_String (Key),
Cookie_Record);
end Set;
------------------------------
procedure Put_CGI_Header_With_Cookies
(Header : in String := "Content-type: text/html")
is
procedure Put_Cookie (Key : in Unbounded_String;
Datas : in Key_Values_Record;
N : in Positive;
Continue : in out Boolean) is
begin
Text_IO.Put ("Set-Cookie: ");
Text_IO.Put (To_String (Key) & '=' & To_String (Datas.Value));
if Datas.Expires /= Null_Unbounded_String then
Text_IO.Put ("; expires=" & To_String (Datas.Expires));
end if;
if Datas.Path /= Null_Unbounded_String then
Text_IO.Put ("; path=" & To_String (Datas.Path));
end if;
if Datas.Domain /= Null_Unbounded_String then
Text_IO.Put ("; domain=" & To_String (Datas.Domain));
end if;
if Datas.Secure then
Text_IO.Put ("; secure");
end if;
Text_IO.New_Line;
Continue := True;
end Put_Cookie;
procedure For_Every_Cookies is
new Cookie_Table.Traverse_ASC_G (Put_Cookie);
begin
-- CGI Header
Text_IO.Put_Line (Header);
-- Cookies
For_Every_Cookies (Set_Cookie_Data);
Text_IO.New_Line;
end Put_CGI_Header_With_Cookies;
------------------------------
-- Initialization routines, including some private procedures only
-- used during initialization.
function Field_End
(Data : Unbounded_String;
Field_Separator : Character;
Starting_At : Positive := 1)
return Natural
is
-- Return the end-of-field position in Data after "Starting_Index",
-- assuming that fields are separated by the Field_Separator.
-- If there's no Field_Separator, return the end of the Data.
begin
for I in Starting_At .. Length (Data) loop
if Element (Data, I) = Field_Separator then
return I - 1;
end if;
end loop;
return Length (Data);
end Field_End;
------------------------------
function Hex_Value (H : in String) return Natural is
-- Given hex string, return its Value as a Natural.
Value : Natural := 0;
begin
for P in 1.. H'Length loop
Value := Value * 16;
if H(P) in '0' .. '9' then
Value := Value + Character'Pos(H(P)) - Character'Pos('0');
elsif H(P) in 'A' .. 'F' then
Value := Value + Character'Pos(H(P)) - Character'Pos('A') + 10;
elsif H(P) in 'a' .. 'f' then
Value := Value + Character'Pos(H(P)) - Character'Pos('a') + 10;
else
raise Constraint_Error;
end if;
end loop;
return Value;
end Hex_Value;
------------------------------
procedure Decode (Data : in out Unbounded_String)
is
use Characters.Handling;
I : Positive := 1;
-- In the given string, convert pattern %HH into alphanumeric
characters,
-- where HH is a hex number. Since this encoding only permits values
-- from %00 to %FF, there's no need to handle 16-bit characters.
begin
while I <= Length(Data) - 2 loop
if Element (Data, I) = '%' and
Is_Hexadecimal_Digit (Element (Data, I+1)) and
Is_Hexadecimal_Digit (Element (Data, I+2)) then
Replace_Element
(Data, I,
Character'Val (Hex_Value (Slice (Data, I+1, I+2))));
Delete (Data, I+1, I+2);
end if;
I := I + 1;
end loop;
end Decode;
------------------------------
procedure Set_CGI_Position
(Key_Number : in Positive;
Datum : in Unbounded_String)
is
Last : Natural := Field_End(Datum, '=');
-- Given a Key number and a datum of the form key=value
-- assign the CGI_Data(Key_Number) the values of key and value.
begin
Cookie_Data (Key_Number).Key
:= To_Unbounded_String (Slice (Datum, 1, Last));
Cookie_Data (Key_Number).Value
:= To_Unbounded_String (Slice (Datum, Last+2, Length (Datum)));
Decode (Cookie_Data (Key_Number).Key);
Decode (Cookie_Data (Key_Number).Value);
end Set_CGI_Position;
------------------------------
procedure Set_CGI_Data (Raw_Data : in Unbounded_String) is
-- Set CGI_Data using Raw_Data.
Key_Number : Positive := 1;
Character_Position : Positive := 1;
Last : Natural;
begin
while Character_Position <= Length (Raw_Data) loop
Last := Field_End (Raw_Data, ';', Character_Position);
Set_CGI_Position
(Key_Number,
To_Unbounded_String (Slice (Raw_Data, Character_Position,
Last)));
Character_Position := Last + 3; -- Skip over field separator. "; "
Key_Number := Key_Number + 1;
end loop;
end Set_CGI_Data;
------------------------------
procedure Initialize is
Raw_Data : Unbounded_String;
begin
Raw_Data := To_Unbounded_String (Get_Environment("HTTP_COOKIE"));
Translate (Raw_Data, Mapping => Plus_To_Space);
if Length (Raw_Data) > 0 then
Cookie_Data :=
new Key_Value_Sequence (1 .. Count (Raw_Data, ";") + 1);
Set_CGI_Data (Raw_Data);
end if;
end Initialize;
begin
Initialize;
end CGI.Cookies;
---------------------------------- CUT
HERE -----------------------------------------------
^ permalink raw reply [flat|nested] 5+ messages in thread