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 801

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                       G N A T . C G I . C O O K I E                      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2000-2010, AdaCore                     --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
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;
   --  This boolean will be set to True if the initialization was fine
 
   Header_Sent : Boolean := False;
   --  Will be set to True when the header will be sent
 
   --  Cookie data that has been added
 
   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);
   --  This is the table to keep all cookies to be sent back to the server
 
   package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
   --  This is the table to keep all cookies received from the server
 
   procedure Check_Environment;
   pragma Inline (Check_Environment);
   --  This procedure will raise Data_Error if Valid_Environment is False
 
   procedure Initialize;
   --  Initialize CGI package by reading the runtime environment. This
   --  procedure is called during elaboration. All exceptions raised during
   --  this procedure are deferred.
 
   -----------------------
   -- Check_Environment --
   -----------------------
 
   procedure Check_Environment is
   begin
      if not Valid_Environment then
         raise Data_Error;
      end if;
   end Check_Environment;
 
   -----------
   -- Count --
   -----------
 
   function Count return Natural is
   begin
      return Key_Value_Table.Last;
   end Count;
 
   ------------
   -- Exists --
   ------------
 
   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;
 
   ----------------------
   -- For_Every_Cookie --
   ----------------------
 
   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;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize is
 
      HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie);
 
      procedure Set_Parameter_Table (Data : String);
      --  Parse Data and insert information in Key_Value_Table
 
      -------------------------
      -- Set_Parameter_Table --
      -------------------------
 
      procedure Set_Parameter_Table (Data : String) is
 
         procedure Add_Parameter (K : Positive; P : String);
         --  Add a single parameter into the table at index K. The parameter
         --  format is "key=value".
 
         Count : constant Positive :=
                   1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";"));
         --  Count is the number of parameters in the string. Parameters are
         --  separated by ampersand character.
 
         Index : Positive := Data'First;
         Sep   : Natural;
 
         -------------------
         -- Add_Parameter --
         -------------------
 
         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;
 
      --  Start of processing for Set_Parameter_Table
 
      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 last parameter
 
         Add_Parameter (Count, Data (Index .. Data'Last));
      end Set_Parameter_Table;
 
   --  Start of processing for Initialize
 
   begin
      if HTTP_COOKIE /= "" then
         Set_Parameter_Table (HTTP_COOKIE);
      end if;
 
      Valid_Environment := True;
 
   exception
      when others =>
         Valid_Environment := False;
   end Initialize;
 
   ---------
   -- Key --
   ---------
 
   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;
 
   --------
   -- Ok --
   --------
 
   function Ok return Boolean is
   begin
      return Valid_Environment;
   end Ok;
 
   ----------------
   -- Put_Header --
   ----------------
 
   procedure Put_Header
     (Header : String  := Default_Header;
      Force  : Boolean := False)
   is
      procedure Output_Cookies;
      --  Iterate through the list of cookies to be sent to the server
      --  and output them.
 
      --------------------
      -- 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);
         --  Output one cookie in the CGI header
 
         -----------------------
         -- Output_One_Cookie --
         -----------------------
 
         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;
 
      --  Start of processing for Output_Cookies
 
      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;
 
   --  Start of processing for Put_Header
 
   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;
 
   ---------
   -- Set --
   ---------
 
   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;
 
   -----------
   -- Value --
   -----------
 
   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;
 
--  Elaboration code for package
 
begin
   --  Initialize unit by reading the HTTP_COOKIE metavariable and fill
   --  Key_Value_Table structure.
 
   Initialize;
end GNAT.CGI.Cookie;

Browse

Tools

Subversion Repositories openrisc

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

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;`