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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [g-cgicoo.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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