| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T . C G I -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2001-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.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; |
| |
| -- Plus sign is decoded as a space |
| |
| elsif S (K) = '+' then |
| Result (J) := ' '; |
| K := K + 1; |
| |
| 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; |
