1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . C G I . C O O K I E --
9 -- Copyright (C) 2000-2001 Ada Core Technologies, Inc.
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with Ada
.Strings
.Fixed
;
34 with Ada
.Strings
.Maps
;
36 with Ada
.Integer_Text_IO
;
40 package body GNAT
.CGI
.Cookie
is
44 Valid_Environment
: Boolean := False;
45 -- This boolean will be set to True if the initialization was fine.
47 Header_Sent
: Boolean := False;
48 -- Will be set to True when the header will be sent.
50 -- Cookie data that have been added.
52 type String_Access
is access String;
54 type Cookie_Data
is record
56 Value
: String_Access
;
57 Comment
: String_Access
;
58 Domain
: String_Access
;
61 Secure
: Boolean := False;
64 type Key_Value
is record
65 Key
, Value
: String_Access
;
68 package Cookie_Table
is new Table
(Cookie_Data
, Positive, 1, 5, 50);
69 -- This is the table to keep all cookies to be sent back to the server.
71 package Key_Value_Table
is new Table
(Key_Value
, Positive, 1, 1, 50);
72 -- This is the table to keep all cookies received from the server.
74 procedure Check_Environment
;
75 pragma Inline
(Check_Environment
);
76 -- This procedure will raise Data_Error if Valid_Environment is False.
79 -- Initialize CGI package by reading the runtime environment. This
80 -- procedure is called during elaboration. All exceptions raised during
81 -- this procedure are deferred.
83 -----------------------
84 -- Check_Environment --
85 -----------------------
87 procedure Check_Environment
is
89 if not Valid_Environment
then
92 end Check_Environment
;
98 function Count
return Natural is
100 return Key_Value_Table
.Last
;
107 function Exists
(Key
: String) return Boolean is
111 for K
in 1 .. Key_Value_Table
.Last
loop
112 if Key_Value_Table
.Table
(K
).Key
.all = Key
then
120 ----------------------
121 -- For_Every_Cookie --
122 ----------------------
124 procedure For_Every_Cookie
is
130 for K
in 1 .. Key_Value_Table
.Last
loop
133 Action
(Key_Value_Table
.Table
(K
).Key
.all,
134 Key_Value_Table
.Table
(K
).Value
.all,
140 end For_Every_Cookie
;
146 procedure Initialize
is
148 HTTP_COOKIE
: constant String := Metavariable
(CGI
.HTTP_Cookie
);
150 procedure Set_Parameter_Table
(Data
: String);
151 -- Parse Data and insert information in Key_Value_Table.
153 -------------------------
154 -- Set_Parameter_Table --
155 -------------------------
157 procedure Set_Parameter_Table
(Data
: String) is
159 procedure Add_Parameter
(K
: Positive; P
: String);
160 -- Add a single parameter into the table at index K. The parameter
161 -- format is "key=value".
163 Count
: constant Positive
164 := 1 + Strings
.Fixed
.Count
(Data
, Strings
.Maps
.To_Set
(";"));
165 -- Count is the number of parameters in the string. Parameters are
166 -- separated by ampersand character.
168 Index
: Positive := Data
'First;
175 procedure Add_Parameter
(K
: Positive; P
: String) is
176 Equal
: constant Natural := Strings
.Fixed
.Index
(P
, "=");
181 Key_Value_Table
.Table
(K
) :=
182 Key_Value
'(new String'(Decode
(P
(P
'First .. Equal
- 1))),
183 new String'(Decode (P (Equal + 1 .. P'Last))));
188 Key_Value_Table.Set_Last (Count);
190 for K in 1 .. Count - 1 loop
191 Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
193 Add_Parameter (K, Data (Index .. Sep - 1));
198 -- add last parameter
200 Add_Parameter (Count, Data (Index .. Data'Last));
201 end Set_Parameter_Table;
204 if HTTP_COOKIE /= "" then
205 Set_Parameter_Table (HTTP_COOKIE);
208 Valid_Environment := True;
212 Valid_Environment := False;
219 function Key (Position : Positive) return String is
223 if Position <= Key_Value_Table.Last then
224 return Key_Value_Table.Table (Position).Key.all;
226 raise Cookie_Not_Found;
234 function Ok return Boolean is
236 return Valid_Environment;
244 (Header : String := Default_Header;
245 Force : Boolean := False)
248 procedure Output_Cookies;
249 -- Iterate through the list of cookies to be sent to the server
256 procedure Output_Cookies is
258 procedure Output_One_Cookie
266 -- Output one cookie in the CGI header.
268 -----------------------
269 -- Output_One_Cookie --
270 -----------------------
272 procedure Output_One_Cookie
282 Text_IO.Put ("Set-Cookie: ");
283 Text_IO.Put (Key & '=' & Value);
285 if Comment /= "" then
286 Text_IO.Put ("; Comment=" & Comment);
290 Text_IO.Put ("; Domain=" & Domain);
293 if Max_Age /= Natural'Last then
294 Text_IO.Put ("; Max-Age=");
295 Integer_Text_IO.Put (Max_Age, Width => 0);
299 Text_IO.Put ("; Path=" & Path);
303 Text_IO.Put ("; Secure");
307 end Output_One_Cookie;
309 -- Start of processing for Output_Cookies
312 for C in 1 .. Cookie_Table.Last loop
313 Output_One_Cookie (Cookie_Table.Table (C).Key.all,
314 Cookie_Table.Table (C).Value.all,
315 Cookie_Table.Table (C).Comment.all,
316 Cookie_Table.Table (C).Domain.all,
317 Cookie_Table.Table (C).Max_Age,
318 Cookie_Table.Table (C).Path.all,
319 Cookie_Table.Table (C).Secure);
323 -- Start of processing for Put_Header
326 if Header_Sent = False or else Force then
328 Text_IO.Put_Line (Header);
342 Comment : String := "";
343 Domain : String := "";
344 Max_Age : Natural := Natural'Last;
345 Path : String := "/";
346 Secure : Boolean := False) is
348 Cookie_Table.Increment_Last;
350 Cookie_Table.Table (Cookie_Table.Last) :=
351 Cookie_Data'(new String'(Key),
353 new String'(Comment),
366 Required : Boolean := False)
372 for K in 1 .. Key_Value_Table.Last loop
373 if Key_Value_Table.Table (K).Key.all = Key then
374 return Key_Value_Table.Table (K).Value.all;
379 raise Cookie_Not_Found;
385 function Value (Position : Positive) return String is
389 if Position <= Key_Value_Table.Last then
390 return Key_Value_Table.Table (Position).Value.all;
392 raise Cookie_Not_Found;
396 -- Elaboration code for package
399 -- Initialize unit by reading the HTTP_COOKIE metavariable and fill
400 -- Key_Value_Table structure.