OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [g-cgicoo.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                       G N A T . C G I . C O O K I E                      --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                     Copyright (C) 2000-2005, AdaCore                     --
10
--                                                                          --
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,  51  Franklin  Street,  Fifth  Floor, --
20
-- Boston, MA 02110-1301, USA.                                              --
21
--                                                                          --
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.                                      --
28
--                                                                          --
29
-- GNAT was originally developed  by the GNAT team at  New York University. --
30
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31
--                                                                          --
32
------------------------------------------------------------------------------
33
 
34
with Ada.Strings.Fixed;
35
with Ada.Strings.Maps;
36
with Ada.Text_IO;
37
with Ada.Integer_Text_IO;
38
 
39
with GNAT.Table;
40
 
41
package body GNAT.CGI.Cookie is
42
 
43
   use Ada;
44
 
45
   Valid_Environment : Boolean := False;
46
   --  This boolean will be set to True if the initialization was fine
47
 
48
   Header_Sent : Boolean := False;
49
   --  Will be set to True when the header will be sent
50
 
51
   --  Cookie data that has been added
52
 
53
   type String_Access is access String;
54
 
55
   type Cookie_Data is record
56
      Key     : String_Access;
57
      Value   : String_Access;
58
      Comment : String_Access;
59
      Domain  : String_Access;
60
      Max_Age : Natural;
61
      Path    : String_Access;
62
      Secure  : Boolean := False;
63
   end record;
64
 
65
   type Key_Value is record
66
      Key, Value : String_Access;
67
   end record;
68
 
69
   package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50);
70
   --  This is the table to keep all cookies to be sent back to the server
71
 
72
   package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
73
   --  This is the table to keep all cookies received from the server
74
 
75
   procedure Check_Environment;
76
   pragma Inline (Check_Environment);
77
   --  This procedure will raise Data_Error if Valid_Environment is False
78
 
79
   procedure Initialize;
80
   --  Initialize CGI package by reading the runtime environment. This
81
   --  procedure is called during elaboration. All exceptions raised during
82
   --  this procedure are deferred.
83
 
84
   -----------------------
85
   -- Check_Environment --
86
   -----------------------
87
 
88
   procedure Check_Environment is
89
   begin
90
      if not Valid_Environment then
91
         raise Data_Error;
92
      end if;
93
   end Check_Environment;
94
 
95
   -----------
96
   -- Count --
97
   -----------
98
 
99
   function Count return Natural is
100
   begin
101
      return Key_Value_Table.Last;
102
   end Count;
103
 
104
   ------------
105
   -- Exists --
106
   ------------
107
 
108
   function Exists (Key : String) return Boolean is
109
   begin
110
      Check_Environment;
111
 
112
      for K in 1 .. Key_Value_Table.Last loop
113
         if Key_Value_Table.Table (K).Key.all = Key then
114
            return True;
115
         end if;
116
      end loop;
117
 
118
      return False;
119
   end Exists;
120
 
121
   ----------------------
122
   -- For_Every_Cookie --
123
   ----------------------
124
 
125
   procedure For_Every_Cookie is
126
      Quit : Boolean;
127
 
128
   begin
129
      Check_Environment;
130
 
131
      for K in 1 .. Key_Value_Table.Last loop
132
         Quit := False;
133
 
134
         Action (Key_Value_Table.Table (K).Key.all,
135
                 Key_Value_Table.Table (K).Value.all,
136
                 K,
137
                 Quit);
138
 
139
         exit when Quit;
140
      end loop;
141
   end For_Every_Cookie;
142
 
143
   ----------------
144
   -- Initialize --
145
   ----------------
146
 
147
   procedure Initialize is
148
 
149
      HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
150
 
151
      procedure Set_Parameter_Table (Data : String);
152
      --  Parse Data and insert information in Key_Value_Table
153
 
154
      -------------------------
155
      -- Set_Parameter_Table --
156
      -------------------------
157
 
158
      procedure Set_Parameter_Table (Data : String) is
159
 
160
         procedure Add_Parameter (K : Positive; P : String);
161
         --  Add a single parameter into the table at index K. The parameter
162
         --  format is "key=value".
163
 
164
         Count : constant Positive :=
165
                   1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
166
         --  Count is the number of parameters in the string. Parameters are
167
         --  separated by ampersand character.
168
 
169
         Index : Positive := Data'First;
170
         Sep   : Natural;
171
 
172
         -------------------
173
         -- Add_Parameter --
174
         -------------------
175
 
176
         procedure Add_Parameter (K : Positive; P : String) is
177
            Equal : constant Natural := Strings.Fixed.Index (P, "=");
178
         begin
179
            if Equal = 0 then
180
               raise Data_Error;
181
            else
182
               Key_Value_Table.Table (K) :=
183
                 Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
184
                            new String'(Decode (P (Equal + 1 .. P'Last))));
185
            end if;
186
         end Add_Parameter;
187
 
188
      --  Start of processing for Set_Parameter_Table
189
 
190
      begin
191
         Key_Value_Table.Set_Last (Count);
192
 
193
         for K in 1 .. Count - 1 loop
194
            Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";");
195
 
196
            Add_Parameter (K, Data (Index .. Sep - 1));
197
 
198
            Index := Sep + 2;
199
         end loop;
200
 
201
         --  Add last parameter
202
 
203
         Add_Parameter (Count, Data (Index .. Data'Last));
204
      end Set_Parameter_Table;
205
 
206
   --  Start of processing for Initialize
207
 
208
   begin
209
      if HTTP_COOKIE /= "" then
210
         Set_Parameter_Table (HTTP_COOKIE);
211
      end if;
212
 
213
      Valid_Environment := True;
214
 
215
   exception
216
      when others =>
217
         Valid_Environment := False;
218
   end Initialize;
219
 
220
   ---------
221
   -- Key --
222
   ---------
223
 
224
   function Key (Position : Positive) return String is
225
   begin
226
      Check_Environment;
227
 
228
      if Position <= Key_Value_Table.Last then
229
         return Key_Value_Table.Table (Position).Key.all;
230
      else
231
         raise Cookie_Not_Found;
232
      end if;
233
   end Key;
234
 
235
   --------
236
   -- Ok --
237
   --------
238
 
239
   function Ok return Boolean is
240
   begin
241
      return Valid_Environment;
242
   end Ok;
243
 
244
   ----------------
245
   -- Put_Header --
246
   ----------------
247
 
248
   procedure Put_Header
249
     (Header : String  := Default_Header;
250
      Force  : Boolean := False)
251
   is
252
      procedure Output_Cookies;
253
      --  Iterate through the list of cookies to be sent to the server
254
      --  and output them.
255
 
256
      --------------------
257
      -- Output_Cookies --
258
      --------------------
259
 
260
      procedure Output_Cookies is
261
 
262
         procedure Output_One_Cookie
263
           (Key     : String;
264
            Value   : String;
265
            Comment : String;
266
            Domain  : String;
267
            Max_Age : Natural;
268
            Path    : String;
269
            Secure  : Boolean);
270
         --  Output one cookie in the CGI header
271
 
272
         -----------------------
273
         -- Output_One_Cookie --
274
         -----------------------
275
 
276
         procedure Output_One_Cookie
277
           (Key     : String;
278
            Value   : String;
279
            Comment : String;
280
            Domain  : String;
281
            Max_Age : Natural;
282
            Path    : String;
283
            Secure  : Boolean)
284
         is
285
         begin
286
            Text_IO.Put ("Set-Cookie: ");
287
            Text_IO.Put (Key & '=' & Value);
288
 
289
            if Comment /= "" then
290
               Text_IO.Put ("; Comment=" & Comment);
291
            end if;
292
 
293
            if Domain /= "" then
294
               Text_IO.Put ("; Domain=" & Domain);
295
            end if;
296
 
297
            if Max_Age /= Natural'Last then
298
               Text_IO.Put ("; Max-Age=");
299
               Integer_Text_IO.Put (Max_Age, Width => 0);
300
            end if;
301
 
302
            if Path /= "" then
303
               Text_IO.Put ("; Path=" & Path);
304
            end if;
305
 
306
            if Secure then
307
               Text_IO.Put ("; Secure");
308
            end if;
309
 
310
            Text_IO.New_Line;
311
         end Output_One_Cookie;
312
 
313
      --  Start of processing for Output_Cookies
314
 
315
      begin
316
         for C in 1 .. Cookie_Table.Last loop
317
            Output_One_Cookie (Cookie_Table.Table (C).Key.all,
318
                               Cookie_Table.Table (C).Value.all,
319
                               Cookie_Table.Table (C).Comment.all,
320
                               Cookie_Table.Table (C).Domain.all,
321
                               Cookie_Table.Table (C).Max_Age,
322
                               Cookie_Table.Table (C).Path.all,
323
                               Cookie_Table.Table (C).Secure);
324
         end loop;
325
      end Output_Cookies;
326
 
327
   --  Start of processing for Put_Header
328
 
329
   begin
330
      if Header_Sent = False or else Force then
331
         Check_Environment;
332
         Text_IO.Put_Line (Header);
333
         Output_Cookies;
334
         Text_IO.New_Line;
335
         Header_Sent := True;
336
      end if;
337
   end Put_Header;
338
 
339
   ---------
340
   -- Set --
341
   ---------
342
 
343
   procedure Set
344
     (Key     : String;
345
      Value   : String;
346
      Comment : String   := "";
347
      Domain  : String   := "";
348
      Max_Age : Natural  := Natural'Last;
349
      Path    : String   := "/";
350
      Secure  : Boolean  := False)
351
   is
352
   begin
353
      Cookie_Table.Increment_Last;
354
 
355
      Cookie_Table.Table (Cookie_Table.Last) :=
356
        Cookie_Data'(new String'(Key),
357
                     new String'(Value),
358
                     new String'(Comment),
359
                     new String'(Domain),
360
                     Max_Age,
361
                     new String'(Path),
362
                     Secure);
363
   end Set;
364
 
365
   -----------
366
   -- Value --
367
   -----------
368
 
369
   function Value
370
     (Key      : String;
371
      Required : Boolean := False) return String
372
   is
373
   begin
374
      Check_Environment;
375
 
376
      for K in 1 .. Key_Value_Table.Last loop
377
         if Key_Value_Table.Table (K).Key.all = Key then
378
            return Key_Value_Table.Table (K).Value.all;
379
         end if;
380
      end loop;
381
 
382
      if Required then
383
         raise Cookie_Not_Found;
384
      else
385
         return "";
386
      end if;
387
   end Value;
388
 
389
   function Value (Position : Positive) return String is
390
   begin
391
      Check_Environment;
392
 
393
      if Position <= Key_Value_Table.Last then
394
         return Key_Value_Table.Table (Position).Value.all;
395
      else
396
         raise Cookie_Not_Found;
397
      end if;
398
   end Value;
399
 
400
--  Elaboration code for package
401
 
402
begin
403
   --  Initialize unit by reading the HTTP_COOKIE metavariable and fill
404
   --  Key_Value_Table structure.
405
 
406
   Initialize;
407
end GNAT.CGI.Cookie;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.