+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . C G I --
--- --
--- B o d y --
--- --
--- $Revision: 1.1 $
--- --
--- 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff