diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-cgi.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/g-cgi.adb | 490 |
1 files changed, 0 insertions, 490 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-cgi.adb b/gcc-4.4.3/gcc/ada/g-cgi.adb deleted file mode 100644 index 34f3e4f32..000000000 --- a/gcc-4.4.3/gcc/ada/g-cgi.adb +++ /dev/null @@ -1,490 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2006, 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.Text_IO; -with Ada.Strings.Fixed; -with Ada.Characters.Handling; -with Ada.Strings.Maps; - -with GNAT.OS_Lib; -with GNAT.Table; - -package body GNAT.CGI is - - use Ada; - - Valid_Environment : Boolean := True; - -- This boolean will be set to False if the initialization was not - -- completed correctly. It must be set to true there because the - -- Initialize routine (called during elaboration) will use some of the - -- services exported by this unit. - - Current_Method : Method_Type; - -- This is the current method used to pass CGI parameters - - Header_Sent : Boolean := False; - -- Will be set to True when the header will be sent - - -- Key/Value table declaration - - type String_Access is access String; - - type Key_Value is record - Key : String_Access; - Value : String_Access; - end record; - - package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); - - ----------------------- - -- Local subprograms -- - ----------------------- - - 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. - - -------------------- - -- Argument_Count -- - -------------------- - - function Argument_Count return Natural is - begin - Check_Environment; - return Key_Value_Table.Last; - end Argument_Count; - - ----------------------- - -- Check_Environment -- - ----------------------- - - procedure Check_Environment is - begin - if not Valid_Environment then - raise Data_Error; - end if; - end Check_Environment; - - ------------ - -- Decode -- - ------------ - - function Decode (S : String) return String is - Result : String (S'Range); - K : Positive := S'First; - J : Positive := Result'First; - - begin - while K <= S'Last loop - if K + 2 <= S'Last - and then S (K) = '%' - and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) - and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) - then - -- Here we have '%HH' which is an encoded character where 'HH' is - -- the character number in hexadecimal. - - Result (J) := Character'Val - (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#')); - K := K + 3; - - else - Result (J) := S (K); - K := K + 1; - end if; - - J := J + 1; - end loop; - - return Result (Result'First .. J - 1); - end Decode; - - ------------------------- - -- For_Every_Parameter -- - ------------------------- - - procedure For_Every_Parameter 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_Parameter; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - - Request_Method : constant String := - Characters.Handling.To_Upper - (Metavariable (CGI.Request_Method)); - - procedure Initialize_GET; - -- Read CGI parameters for a GET method. In this case the parameters - -- are passed into QUERY_STRING environment variable. - - procedure Initialize_POST; - -- Read CGI parameters for a POST method. In this case the parameters - -- are passed with the standard input. The total number of characters - -- for the data is passed in CONTENT_LENGTH environment variable. - - procedure Set_Parameter_Table (Data : String); - -- Parse the parameter data and set the parameter table - - -------------------- - -- Initialize_GET -- - -------------------- - - procedure Initialize_GET is - Data : constant String := Metavariable (Query_String); - begin - Current_Method := Get; - - if Data /= "" then - Set_Parameter_Table (Data); - end if; - end Initialize_GET; - - --------------------- - -- Initialize_POST -- - --------------------- - - procedure Initialize_POST is - Content_Length : constant Natural := - Natural'Value (Metavariable (CGI.Content_Length)); - Data : String (1 .. Content_Length); - - begin - Current_Method := Post; - - if Content_Length /= 0 then - Text_IO.Get (Data); - Set_Parameter_Table (Data); - end if; - end Initialize_POST; - - ------------------------- - -- 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; - Amp : 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 - Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); - - Add_Parameter (K, Data (Index .. Amp - 1)); - - Index := Amp + 1; - end loop; - - -- add last parameter - - Add_Parameter (Count, Data (Index .. Data'Last)); - end Set_Parameter_Table; - - -- Start of processing for Initialize - - begin - if Request_Method = "GET" then - Initialize_GET; - - elsif Request_Method = "POST" then - Initialize_POST; - - else - Valid_Environment := False; - end if; - - exception - when others => - - -- If we have an exception during initialization of this unit we - -- just declare it invalid. - - 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 Parameter_Not_Found; - end if; - end Key; - - ---------------- - -- Key_Exists -- - ---------------- - - function Key_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 Key_Exists; - - ------------------ - -- Metavariable -- - ------------------ - - function Metavariable - (Name : Metavariable_Name; - Required : Boolean := False) return String - is - function Get_Environment (Variable_Name : String) return String; - -- Returns the environment variable content - - --------------------- - -- Get_Environment -- - --------------------- - - function Get_Environment (Variable_Name : String) return String is - Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); - Result : constant String := Value.all; - begin - OS_Lib.Free (Value); - return Result; - end Get_Environment; - - Result : constant String := - Get_Environment (Metavariable_Name'Image (Name)); - - -- Start of processing for Metavariable - - begin - Check_Environment; - - if Result = "" and then Required then - raise Parameter_Not_Found; - else - return Result; - end if; - end Metavariable; - - ------------------------- - -- Metavariable_Exists -- - ------------------------- - - function Metavariable_Exists (Name : Metavariable_Name) return Boolean is - begin - Check_Environment; - - if Metavariable (Name) = "" then - return False; - else - return True; - end if; - end Metavariable_Exists; - - ------------ - -- Method -- - ------------ - - function Method return Method_Type is - begin - Check_Environment; - return Current_Method; - end Method; - - -------- - -- 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 - begin - if Header_Sent = False or else Force then - Check_Environment; - Text_IO.Put_Line (Header); - Text_IO.New_Line; - Header_Sent := True; - end if; - end Put_Header; - - --------- - -- URL -- - --------- - - function URL return String is - - function Exists_And_Not_80 (Server_Port : String) return String; - -- Returns ':' & Server_Port if Server_Port is not "80" and the empty - -- string otherwise (80 is the default sever port). - - ----------------------- - -- Exists_And_Not_80 -- - ----------------------- - - function Exists_And_Not_80 (Server_Port : String) return String is - begin - if Server_Port = "80" then - return ""; - else - return ':' & Server_Port; - end if; - end Exists_And_Not_80; - - -- Start of processing for URL - - begin - Check_Environment; - - return "http://" - & Metavariable (Server_Name) - & Exists_And_Not_80 (Metavariable (Server_Port)) - & Metavariable (Script_Name); - end URL; - - ----------- - -- 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 Parameter_Not_Found; - else - return ""; - end if; - end Value; - - ----------- - -- 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 Parameter_Not_Found; - end if; - end Value; - -begin - - Initialize; - -end GNAT.CGI; |