1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 2001 Ada Core Technologies, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
36 with Ada.Strings.Fixed;
37 with Ada.Characters.Handling;
38 with Ada.Strings.Maps;
43 package body GNAT.CGI is
47 Valid_Environment : Boolean := True;
48 -- This boolean will be set to False if the initialization was not
49 -- completed correctly. It must be set to true there because the
50 -- Initialize routine (called during elaboration) will use some of the
51 -- services exported by this unit.
53 Current_Method : Method_Type;
54 -- This is the current method used to pass CGI parameters.
56 Header_Sent : Boolean := False;
57 -- Will be set to True when the header will be sent.
59 -- Key/Value table declaration
61 type String_Access is access String;
63 type Key_Value is record
65 Value : String_Access;
68 package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50);
70 -----------------------
71 -- Local subprograms --
72 -----------------------
74 procedure Check_Environment;
75 pragma Inline (Check_Environment);
76 -- This procedure will raise Data_Error if Valid_Environment is False.
79 -- Initialize CGI package by reading the runtime environment. This
80 -- procedure is called during elaboration. All exceptions raised during
81 -- this procedure are deferred.
87 function Argument_Count return Natural is
90 return Key_Value_Table.Last;
93 -----------------------
94 -- Check_Environment --
95 -----------------------
97 procedure Check_Environment is
99 if not Valid_Environment then
102 end Check_Environment;
108 function Decode (S : String) return String is
109 Result : String (S'Range);
110 K : Positive := S'First;
111 J : Positive := Result'First;
114 while K <= S'Last loop
117 and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
118 and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
120 -- Here we have '%HH' which is an encoded character where 'HH' is
121 -- the character number in hexadecimal.
123 Result (J) := Character'Val
124 (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#'));
135 return Result (Result'First .. J - 1);
138 -------------------------
139 -- For_Every_Parameter --
140 -------------------------
142 procedure For_Every_Parameter is
148 for K in 1 .. Key_Value_Table.Last loop
152 Action (Key_Value_Table.Table (K).Key.all,
153 Key_Value_Table.Table (K).Value.all,
160 end For_Every_Parameter;
166 procedure Initialize is
168 Request_Method : constant String :=
169 Characters.Handling.To_Upper
170 (Metavariable (CGI.Request_Method));
172 procedure Initialize_GET;
173 -- Read CGI parameters for a GET method. In this case the parameters
174 -- are passed into QUERY_STRING environment variable.
176 procedure Initialize_POST;
177 -- Read CGI parameters for a POST method. In this case the parameters
178 -- are passed with the standard input. The total number of characters
179 -- for the data is passed in CONTENT_LENGTH environment variable.
181 procedure Set_Parameter_Table (Data : String);
182 -- Parse the parameter data and set the parameter table.
188 procedure Initialize_GET is
189 Data : constant String := Metavariable (Query_String);
191 Current_Method := Get;
193 Set_Parameter_Table (Data);
197 ---------------------
198 -- Initialize_POST --
199 ---------------------
201 procedure Initialize_POST is
202 Content_Length : constant Natural :=
203 Natural'Value (Metavariable (CGI.Content_Length));
204 Data : String (1 .. Content_Length);
207 Current_Method := Post;
209 if Content_Length /= 0 then
211 Set_Parameter_Table (Data);
215 -------------------------
216 -- Set_Parameter_Table --
217 -------------------------
219 procedure Set_Parameter_Table (Data : String) is
221 procedure Add_Parameter (K : Positive; P : String);
222 -- Add a single parameter into the table at index K. The parameter
223 -- format is "key=value".
225 Count : constant Positive :=
226 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&"));
227 -- Count is the number of parameters in the string. Parameters are
228 -- separated by ampersand character.
230 Index : Positive := Data'First;
237 procedure Add_Parameter (K : Positive; P : String) is
238 Equal : constant Natural := Strings.Fixed.Index (P, "=");
245 Key_Value_Table.Table (K) :=
246 Key_Value'(new String'(Decode (P (P'First .. Equal - 1))),
247 new String'(Decode (P (Equal + 1 .. P'Last))));
251 -- Start of processing for Set_Parameter_Table
254 Key_Value_Table.Set_Last (Count);
256 for K in 1 .. Count - 1 loop
257 Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&");
259 Add_Parameter (K, Data (Index .. Amp - 1));
264 -- add last parameter
266 Add_Parameter (Count, Data (Index .. Data'Last));
267 end Set_Parameter_Table;
269 -- Start of processing for Initialize
272 if Request_Method = "GET" then
275 elsif Request_Method = "POST" then
279 Valid_Environment := False;
285 -- If we have an exception during initialization of this unit we
286 -- just declare it invalid.
288 Valid_Environment := False;
295 function Key (Position : Positive) return String is
299 if Position <= Key_Value_Table.Last then
300 return Key_Value_Table.Table (Position).Key.all;
302 raise Parameter_Not_Found;
310 function Key_Exists (Key : String) return Boolean is
314 for K in 1 .. Key_Value_Table.Last loop
315 if Key_Value_Table.Table (K).Key.all = Key then
327 function Metavariable
328 (Name : Metavariable_Name;
329 Required : Boolean := False) return String
331 function Get_Environment (Variable_Name : String) return String;
332 -- Returns the environment variable content.
334 ---------------------
335 -- Get_Environment --
336 ---------------------
338 function Get_Environment (Variable_Name : String) return String is
339 Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name);
340 Result : constant String := Value.all;
347 Result : constant String :=
348 Get_Environment (Metavariable_Name'Image (Name));
350 -- Start of processing for Metavariable
355 if Result = "" and then Required then
356 raise Parameter_Not_Found;
362 -------------------------
363 -- Metavariable_Exists --
364 -------------------------
366 function Metavariable_Exists (Name : Metavariable_Name) return Boolean is
370 if Metavariable (Name) = "" then
375 end Metavariable_Exists;
381 function Method return Method_Type is
384 return Current_Method;
391 function Ok return Boolean is
393 return Valid_Environment;
401 (Header : String := Default_Header;
402 Force : Boolean := False)
405 if Header_Sent = False or else Force then
407 Text_IO.Put_Line (Header);
417 function URL return String is
419 function Exists_And_Not_80 (Server_Port : String) return String;
420 -- Returns ':' & Server_Port if Server_Port is not "80" and the empty
421 -- string otherwise (80 is the default sever port).
423 -----------------------
424 -- Exists_And_Not_80 --
425 -----------------------
427 function Exists_And_Not_80 (Server_Port : String) return String is
429 if Server_Port = "80" then
432 return ':' & Server_Port;
434 end Exists_And_Not_80;
436 -- Start of processing for URL
442 & Metavariable (Server_Name)
443 & Exists_And_Not_80 (Metavariable (Server_Port))
444 & Metavariable (Script_Name);
453 Required : Boolean := False)
459 for K in 1 .. Key_Value_Table.Last loop
460 if Key_Value_Table.Table (K).Key.all = Key then
461 return Key_Value_Table.Table (K).Value.all;
466 raise Parameter_Not_Found;
476 function Value (Position : Positive) return String is
480 if Position <= Key_Value_Table.Last then
481 return Key_Value_Table.Table (Position).Value.all;
483 raise Parameter_Not_Found;