diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/g-cgicoo.adb')
| -rw-r--r-- | gcc-4.4.0/gcc/ada/g-cgicoo.adb | 407 |
1 files changed, 0 insertions, 407 deletions
diff --git a/gcc-4.4.0/gcc/ada/g-cgicoo.adb b/gcc-4.4.0/gcc/ada/g-cgicoo.adb deleted file mode 100644 index 50c9ce864..000000000 --- a/gcc-4.4.0/gcc/ada/g-cgicoo.adb +++ /dev/null @@ -1,407 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I . C O O K I E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2005, 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 2, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- 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; |