------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . C G I -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001 Ada Core Technologies, Inc. -- -- -- -- 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, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, 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;